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

      INTEGER N
      REAL TFFt 
      REAL, DIMENSION(N+15) :: Wsave

      COMMON /HRF   / TFFt
      TFFt = 0.
      IF ( N==1 ) RETURN
      CALL HRFTI1(N,Wsave(1),Wsave(N+1))
      END SUBROUTINE HRFFTI

      SUBROUTINE HRFTI1(N,Wa,Fac)
      IMPLICIT NONE

      REAL fi
      REAL, DIMENSION(15) :: Fac
      REAL, DIMENSION(N) :: Wa
      INTEGER i , ib , ido , ii , ip , ipm , is , j , k1 , l1 , l2 ,    &
            & ld , N , nf , nfm1 , nl , nq , nr , ntry , ntryh
!
!     a multiple fft package for spherepack
!
      DIMENSION ntryh(4)
      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
 100  j = j + 1
      IF ( j<=4 ) THEN
         ntry = ntryh(j)
      ELSE
         ntry = ntry + 2
      ENDIF
 200  nq = nl/ntry
      nr = nl - ntry*nq
      IF ( nr/=0 ) GOTO 100
      nf = nf + 1
      Fac(nf+2) = ntry
      nl = nq
      IF ( ntry==2 ) THEN
         IF ( nf/=1 ) THEN
            DO i = 2 , nf
               ib = nf - i + 2
               Fac(ib+2) = Fac(ib+1)
            ENDDO
            Fac(3) = 2
         ENDIF
      ENDIF
      IF ( nl/=1 ) GOTO 200
      Fac(1) = N
      Fac(2) = nf
      tpi = 8.D0*DATAN(1.D0)
      argh = tpi/FLOAT(N)
      is = 0
      nfm1 = nf - 1
      l1 = 1
      IF ( nfm1==0 ) RETURN
      DO k1 = 1 , nfm1
         ip = Fac(k1+2)
         ld = 0
         l2 = l1*ip
         ido = N/l2
         ipm = ip - 1
         DO j = 1 , ipm
            ld = ld + l1
            i = is
            argld = FLOAT(ld)*argh
            fi = 0.
            DO ii = 3 , ido , 2
               i = i + 2
               fi = fi + 1.
               arg = fi*argld
               Wa(i-1) = DCOS(arg)
               Wa(i) = DSIN(arg)
            ENDDO
            is = is + ido
         ENDDO
         l1 = l2
      ENDDO
      END SUBROUTINE HRFTI1


      SUBROUTINE HRFFTF(M,N,R,Mdimr,Whrfft,Work)
      IMPLICIT NONE

      INTEGER M , Mdimr , N
      REAL R , TFFt , Whrfft , Work
!
!     a multiple fft package for spherepack
!
      DIMENSION R(Mdimr,N) , Work(1) , Whrfft(N+15)
      COMMON /HRF   / TFFt
      IF ( N==1 ) RETURN
!     tstart = second(dum)
      CALL HRFTF1(M,N,R,Mdimr,Work,Whrfft,Whrfft(N+1))
!     tfft = tfft+second(dum)-tstart
      END SUBROUTINE HRFFTF

      SUBROUTINE HRFTF1(M,N,C,Mdimc,Ch,Wa,Fac)
      IMPLICIT NONE

      REAL C , Ch , Fac , Wa
      INTEGER i , idl1 , ido , ip , iw , ix2 , ix3 , ix4 , j , k1 , kh ,&
            & l1 , l2 , M , Mdimc , N , na , nf
!
!     a multiple fft package for spherepack
!
      DIMENSION Ch(M,N) , C(Mdimc,N) , Wa(N) , Fac(15)
      nf = Fac(2)
      na = 1
      l2 = N
      iw = N
      DO 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==4 ) THEN
            ix2 = iw + ido
            ix3 = ix2 + ido
            IF ( na/=0 ) THEN
               CALL HRADF4(M,ido,l1,Ch,M,C,Mdimc,Wa(iw),Wa(ix2),Wa(ix3))
            ELSE
               CALL HRADF4(M,ido,l1,C,Mdimc,Ch,M,Wa(iw),Wa(ix2),Wa(ix3))
            ENDIF
         ELSEIF ( ip/=2 ) THEN
            IF ( ip==3 ) THEN
               ix2 = iw + ido
               IF ( na/=0 ) THEN
                  CALL HRADF3(M,ido,l1,Ch,M,C,Mdimc,Wa(iw),Wa(ix2))
               ELSE
                  CALL HRADF3(M,ido,l1,C,Mdimc,Ch,M,Wa(iw),Wa(ix2))
               ENDIF
            ELSEIF ( ip/=5 ) THEN
               IF ( ido==1 ) na = 1 - na
               IF ( na/=0 ) THEN
                  CALL HRADFG(M,ido,ip,l1,idl1,Ch,Ch,Ch,M,C,C,Mdimc,    &
                            & Wa(iw))
                  na = 0
               ELSE
                  CALL HRADFG(M,ido,ip,l1,idl1,C,C,C,Mdimc,Ch,Ch,M,     &
                            & Wa(iw))
                  na = 1
               ENDIF
            ELSE
               ix2 = iw + ido
               ix3 = ix2 + ido
               ix4 = ix3 + ido
               IF ( na/=0 ) THEN
                  CALL HRADF5(M,ido,l1,Ch,M,C,Mdimc,Wa(iw),Wa(ix2),     &
                            & Wa(ix3),Wa(ix4))
               ELSE
                  CALL HRADF5(M,ido,l1,C,Mdimc,Ch,M,Wa(iw),Wa(ix2),     &
                            & Wa(ix3),Wa(ix4))
               ENDIF
            ENDIF
         ELSEIF ( na/=0 ) THEN
            CALL HRADF2(M,ido,l1,Ch,M,C,Mdimc,Wa(iw))
         ELSE
            CALL HRADF2(M,ido,l1,C,Mdimc,Ch,M,Wa(iw))
         ENDIF
         l2 = l1
      ENDDO
      IF ( na==1 ) RETURN
      DO j = 1 , N
         DO i = 1 , M
            C(i,j) = Ch(i,j)
         ENDDO
      ENDDO
      END SUBROUTINE HRFTF1

      SUBROUTINE HRADF4(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1,Wa2,Wa3)
      IMPLICIT NONE

      REAL Cc , Ch , hsqt2 , Wa1 , Wa2 , Wa3
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp
!
!     a multiple fft package for spherepack
!
      DIMENSION Cc(Mdimcc,Ido,L1,4) , Ch(Mdimch,Ido,4,L1) , Wa1(Ido) ,  &
              & Wa2(Ido) , Wa3(Ido)
      hsqt2 = SQRT(2.)/2.
      DO k = 1 , L1
         DO 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)
         ENDDO
      ENDDO
      IF ( Ido<2 ) GOTO 99999
      IF ( Ido/=2 ) THEN
         idp2 = Ido + 2
         DO k = 1 , L1
            DO i = 3 , Ido , 2
               ic = idp2 - i
               DO 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)))
               ENDDO
            ENDDO
         ENDDO
         IF ( MOD(Ido,2)==1 ) RETURN
      ENDIF
      DO k = 1 , L1
         DO 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)
         ENDDO
      ENDDO
99999 END SUBROUTINE HRADF4

      SUBROUTINE HRADF2(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1)
      IMPLICIT NONE

      REAL Cc , Ch , Wa1
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp
!
!     a multiple fft package for spherepack
!
      DIMENSION Ch(Mdimch,Ido,2,L1) , Cc(Mdimcc,Ido,L1,2) , Wa1(Ido)
      DO k = 1 , L1
         DO 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)
         ENDDO
      ENDDO
      IF ( Ido<2 ) GOTO 99999
      IF ( Ido/=2 ) THEN
         idp2 = Ido + 2
         DO k = 1 , L1
            DO i = 3 , Ido , 2
               ic = idp2 - i
               DO 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))
               ENDDO
            ENDDO
         ENDDO
         IF ( MOD(Ido,2)==1 ) RETURN
      ENDIF
      DO k = 1 , L1
         DO m = 1 , Mp
            Ch(m,1,2,k) = -Cc(m,Ido,k,2)
            Ch(m,Ido,1,k) = Cc(m,Ido,k,1)
         ENDDO
      ENDDO
99999 END SUBROUTINE HRADF2

      SUBROUTINE HRADF3(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1,Wa2)
      IMPLICIT NONE

      REAL arg , Cc , Ch , PIMACH , taui , taur , Wa1 , Wa2
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp
!
!     a multiple fft package for spherepack
!
      DIMENSION Ch(Mdimch,Ido,3,L1) , Cc(Mdimcc,Ido,L1,3) , Wa1(Ido) ,  &
              & Wa2(Ido)
      arg = 2.*PIMACH()/3.
      taur = COS(arg)
      taui = SIN(arg)
      DO k = 1 , L1
         DO 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))
         ENDDO
      ENDDO
      IF ( Ido==1 ) RETURN
      idp2 = Ido + 2
      DO k = 1 , L1
         DO i = 3 , Ido , 2
            ic = idp2 - i
            DO 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))))
            ENDDO
         ENDDO
      ENDDO
      END SUBROUTINE HRADF3

      SUBROUTINE HRADF5(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1,Wa2,Wa3,Wa4)
      IMPLICIT NONE
      REAL arg , Cc , Ch , PIMACH , ti11 , ti12 , tr11 , tr12 , Wa1 ,   &
         & Wa2 , Wa3 , Wa4
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp
!
!     a multiple fft package for spherepack
!
      DIMENSION Cc(Mdimcc,Ido,L1,5) , Ch(Mdimch,Ido,5,L1) , Wa1(Ido) ,  &
              & Wa2(Ido) , Wa3(Ido) , Wa4(Ido)
      arg = 2.*PIMACH()/5.
      tr11 = COS(arg)
      ti11 = SIN(arg)
      tr12 = COS(2.*arg)
      ti12 = SIN(2.*arg)
      DO k = 1 , L1
         DO 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))
         ENDDO
      ENDDO
      IF ( Ido==1 ) RETURN
      idp2 = Ido + 2
      DO k = 1 , L1
         DO i = 3 , Ido , 2
            ic = idp2 - i
            DO 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))))
            ENDDO
         ENDDO
      ENDDO
      END SUBROUTINE HRADF5

      SUBROUTINE HRADFG(Mp,Ido,Ip,L1,Idl1,Cc,C1,C2,Mdimcc,Ch,Ch2,Mdimch,&
                      & Wa)
      IMPLICIT NONE
      REAL ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , C1 , C2 , Cc ,   &
         & Ch , Ch2 , dc2 , dcp , ds2 , dsp , PIMACH , tpi , Wa
      INTEGER i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 ,      &
            & ipph , is , j , j2 , jc , k , l , L1 , lc , m , Mdimcc
      INTEGER Mdimch , Mp , nbd
!
!     a multiple fft package for spherepack
!
      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.*PIMACH()
      arg = tpi/FLOAT(Ip)
      dcp = COS(arg)
      dsp = SIN(arg)
      ipph = (Ip+1)/2
      ipp2 = Ip + 2
      idp2 = Ido + 2
      nbd = (Ido-1)/2
      IF ( Ido==1 ) THEN
         DO ik = 1 , Idl1
            DO m = 1 , Mp
               C2(m,ik,1) = Ch2(m,ik,1)
            ENDDO
         ENDDO
      ELSE
         DO ik = 1 , Idl1
            DO m = 1 , Mp
               Ch2(m,ik,1) = C2(m,ik,1)
            ENDDO
         ENDDO
         DO j = 2 , Ip
            DO k = 1 , L1
               DO m = 1 , Mp
                  Ch(m,1,k,j) = C1(m,1,k,j)
               ENDDO
            ENDDO
         ENDDO
         IF ( nbd>L1 ) THEN
            is = -Ido
            DO j = 2 , Ip
               is = is + Ido
               DO k = 1 , L1
                  idij = is
                  DO i = 3 , Ido , 2
                     idij = idij + 2
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ELSE
            is = -Ido
            DO j = 2 , Ip
               is = is + Ido
               idij = is
               DO i = 3 , Ido , 2
                  idij = idij + 2
                  DO k = 1 , L1
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
         IF ( nbd<L1 ) THEN
            DO j = 2 , ipph
               jc = ipp2 - j
               DO i = 3 , Ido , 2
                  DO k = 1 , L1
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ELSE
            DO j = 2 , ipph
               jc = ipp2 - j
               DO k = 1 , L1
                  DO i = 3 , Ido , 2
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      DO j = 2 , ipph
         jc = ipp2 - j
         DO k = 1 , L1
            DO 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)
            ENDDO
         ENDDO
      ENDDO
!
      ar1 = 1.
      ai1 = 0.
      DO l = 2 , ipph
         lc = ipp2 - l
         ar1h = dcp*ar1 - dsp*ai1
         ai1 = dcp*ai1 + dsp*ar1
         ar1 = ar1h
         DO ik = 1 , Idl1
            DO 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)
            ENDDO
         ENDDO
         dc2 = ar1
         ds2 = ai1
         ar2 = ar1
         ai2 = ai1
         DO j = 3 , ipph
            jc = ipp2 - j
            ar2h = dc2*ar2 - ds2*ai2
            ai2 = dc2*ai2 + ds2*ar2
            ar2 = ar2h
            DO ik = 1 , Idl1
               DO 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)
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      DO j = 2 , ipph
         DO ik = 1 , Idl1
            DO m = 1 , Mp
               Ch2(m,ik,1) = Ch2(m,ik,1) + C2(m,ik,j)
            ENDDO
         ENDDO
      ENDDO
!
      IF ( Ido<L1 ) THEN
         DO i = 1 , Ido
            DO k = 1 , L1
               DO m = 1 , Mp
                  Cc(m,i,1,k) = Ch(m,i,k,1)
               ENDDO
            ENDDO
         ENDDO
      ELSE
         DO k = 1 , L1
            DO i = 1 , Ido
               DO m = 1 , Mp
                  Cc(m,i,1,k) = Ch(m,i,k,1)
               ENDDO
            ENDDO
         ENDDO
      ENDIF
      DO j = 2 , ipph
         jc = ipp2 - j
         j2 = j + j
         DO k = 1 , L1
            DO 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)
            ENDDO
         ENDDO
      ENDDO
      IF ( Ido==1 ) RETURN
      IF ( nbd<L1 ) THEN
         DO j = 2 , ipph
            jc = ipp2 - j
            j2 = j + j
            DO i = 3 , Ido , 2
               ic = idp2 - i
               DO k = 1 , L1
                  DO 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)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
         GOTO 99999
      ENDIF
      DO j = 2 , ipph
         jc = ipp2 - j
         j2 = j + j
         DO k = 1 , L1
            DO i = 3 , Ido , 2
               ic = idp2 - i
               DO 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)
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      RETURN
99999 END SUBROUTINE  HRADFG

      FUNCTION PIMACH()
        IMPLICIT NONE
        REAL PIMACH
      PIMACH = 3.14159265358979
      END FUNCTION PIMACH

      FUNCTION DPIMACH()
      IMPLICIT NONE
      DOUBLE PRECISION DPIMACH
      DPIMACH = 3.14159265358979
      END FUNCTION DPIMACH

      SUBROUTINE HRFFTB(M,N,R,Mdimr,Whrfft,Work)
      IMPLICIT NONE
      INTEGER M , Mdimr , N
      REAL R , TFFt , Whrfft , Work
!
!     a multiple fft package for spherepack
!
      DIMENSION R(Mdimr,N) , Work(1) , Whrfft(N+15)
      COMMON /HRF   / TFFt
      IF ( N==1 ) RETURN
!     tstart = second(dum)
      CALL HRFTB1(M,N,R,Mdimr,Work,Whrfft,Whrfft(N+1))
!     tfft = tfft+second(dum)-tstart
      END SUBROUTINE HRFFTB

      SUBROUTINE HRFTB1(M,N,C,Mdimc,Ch,Wa,Fac)
      IMPLICIT NONE
      REAL C , Ch , Fac , Wa
      INTEGER i , idl1 , ido , ip , iw , ix2 , ix3 , ix4 , j , k1 , l1 ,&
            & l2 , M , Mdimc , N , na , nf
!
!     a multiple fft package for spherepack
!
      DIMENSION Ch(M,N) , C(Mdimc,N) , Wa(N) , Fac(15)
      nf = Fac(2)
      na = 0
      l1 = 1
      iw = 1
      DO k1 = 1 , nf
         ip = Fac(k1+2)
         l2 = ip*l1
         ido = N/l2
         idl1 = ido*l1
         IF ( ip==4 ) THEN
            ix2 = iw + ido
            ix3 = ix2 + ido
            IF ( na/=0 ) THEN
               CALL HRADB4(M,ido,l1,Ch,M,C,Mdimc,Wa(iw),Wa(ix2),Wa(ix3))
            ELSE
               CALL HRADB4(M,ido,l1,C,Mdimc,Ch,M,Wa(iw),Wa(ix2),Wa(ix3))
            ENDIF
            na = 1 - na
         ELSEIF ( ip==2 ) THEN
            IF ( na/=0 ) THEN
               CALL HRADB2(M,ido,l1,Ch,M,C,Mdimc,Wa(iw))
            ELSE
               CALL HRADB2(M,ido,l1,C,Mdimc,Ch,M,Wa(iw))
            ENDIF
            na = 1 - na
         ELSEIF ( ip==3 ) THEN
            ix2 = iw + ido
            IF ( na/=0 ) THEN
               CALL HRADB3(M,ido,l1,Ch,M,C,Mdimc,Wa(iw),Wa(ix2))
            ELSE
               CALL HRADB3(M,ido,l1,C,Mdimc,Ch,M,Wa(iw),Wa(ix2))
            ENDIF
            na = 1 - na
         ELSEIF ( ip/=5 ) THEN
            IF ( na/=0 ) THEN
               CALL HRADBG(M,ido,ip,l1,idl1,Ch,Ch,Ch,M,C,C,Mdimc,Wa(iw))
            ELSE
               CALL HRADBG(M,ido,ip,l1,idl1,C,C,C,Mdimc,Ch,Ch,M,Wa(iw))
            ENDIF
            IF ( ido==1 ) na = 1 - na
         ELSE
            ix2 = iw + ido
            ix3 = ix2 + ido
            ix4 = ix3 + ido
            IF ( na/=0 ) THEN
               CALL HRADB5(M,ido,l1,Ch,M,C,Mdimc,Wa(iw),Wa(ix2),Wa(ix3),&
                         & Wa(ix4))
            ELSE
               CALL HRADB5(M,ido,l1,C,Mdimc,Ch,M,Wa(iw),Wa(ix2),Wa(ix3),&
                         & Wa(ix4))
            ENDIF
            na = 1 - na
         ENDIF
         l1 = l2
         iw = iw + (ip-1)*ido
      ENDDO
      IF ( na==0 ) RETURN
      DO j = 1 , N
         DO i = 1 , M
            C(i,j) = Ch(i,j)
         ENDDO
      ENDDO
      END SUBROUTINE HRFTB1

      SUBROUTINE HRADBG(Mp,Ido,Ip,L1,Idl1,Cc,C1,C2,Mdimcc,Ch,Ch2,Mdimch,&
                      & Wa)
      IMPLICIT NONE
      REAL ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , C1 , C2 , Cc ,   &
         & Ch , Ch2 , dc2 , dcp , ds2 , dsp , PIMACH , tpi , Wa
      INTEGER i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 ,      &
            & ipph , is , j , j2 , jc , k , l , L1 , lc , m , Mdimcc
      INTEGER Mdimch , Mp , nbd
!
!     a multiple fft package for spherepack
!
      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.*PIMACH()
      arg = tpi/FLOAT(Ip)
      dcp = COS(arg)
      dsp = SIN(arg)
      idp2 = Ido + 2
      nbd = (Ido-1)/2
      ipp2 = Ip + 2
      ipph = (Ip+1)/2
      IF ( Ido<L1 ) THEN
         DO i = 1 , Ido
            DO k = 1 , L1
               DO m = 1 , Mp
                  Ch(m,i,k,1) = Cc(m,i,1,k)
               ENDDO
            ENDDO
         ENDDO
      ELSE
         DO k = 1 , L1
            DO i = 1 , Ido
               DO m = 1 , Mp
                  Ch(m,i,k,1) = Cc(m,i,1,k)
               ENDDO
            ENDDO
         ENDDO
      ENDIF
      DO j = 2 , ipph
         jc = ipp2 - j
         j2 = j + j
         DO k = 1 , L1
            DO 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)
            ENDDO
         ENDDO
      ENDDO
      IF ( Ido/=1 ) THEN
         IF ( nbd<L1 ) THEN
            DO j = 2 , ipph
               jc = ipp2 - j
               DO i = 3 , Ido , 2
                  ic = idp2 - i
                  DO k = 1 , L1
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ELSE
            DO j = 2 , ipph
               jc = ipp2 - j
               DO k = 1 , L1
                  DO i = 3 , Ido , 2
                     ic = idp2 - i
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      ar1 = 1.
      ai1 = 0.
      DO l = 2 , ipph
         lc = ipp2 - l
         ar1h = dcp*ar1 - dsp*ai1
         ai1 = dcp*ai1 + dsp*ar1
         ar1 = ar1h
         DO ik = 1 , Idl1
            DO 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)
            ENDDO
         ENDDO
         dc2 = ar1
         ds2 = ai1
         ar2 = ar1
         ai2 = ai1
         DO j = 3 , ipph
            jc = ipp2 - j
            ar2h = dc2*ar2 - ds2*ai2
            ai2 = dc2*ai2 + ds2*ar2
            ar2 = ar2h
            DO ik = 1 , Idl1
               DO 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)
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      DO j = 2 , ipph
         DO ik = 1 , Idl1
            DO m = 1 , Mp
               Ch2(m,ik,1) = Ch2(m,ik,1) + Ch2(m,ik,j)
            ENDDO
         ENDDO
      ENDDO
      DO j = 2 , ipph
         jc = ipp2 - j
         DO k = 1 , L1
            DO 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)
            ENDDO
         ENDDO
      ENDDO
      IF ( Ido/=1 ) THEN
         IF ( nbd<L1 ) THEN
            DO j = 2 , ipph
               jc = ipp2 - j
               DO i = 3 , Ido , 2
                  DO k = 1 , L1
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ELSE
            DO j = 2 , ipph
               jc = ipp2 - j
               DO k = 1 , L1
                  DO i = 3 , Ido , 2
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      IF ( Ido==1 ) RETURN
      DO ik = 1 , Idl1
         DO m = 1 , Mp
            C2(m,ik,1) = Ch2(m,ik,1)
         ENDDO
      ENDDO
      DO j = 2 , Ip
         DO k = 1 , L1
            DO m = 1 , Mp
               C1(m,1,k,j) = Ch(m,1,k,j)
            ENDDO
         ENDDO
      ENDDO
      IF ( nbd>L1 ) THEN
         is = -Ido
         DO j = 2 , Ip
            is = is + Ido
            DO k = 1 , L1
               idij = is
               DO i = 3 , Ido , 2
                  idij = idij + 2
                  DO 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)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ELSE
         is = -Ido
         DO j = 2 , Ip
            is = is + Ido
            idij = is
            DO i = 3 , Ido , 2
               idij = idij + 2
               DO k = 1 , L1
                  DO 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)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDIF
      END SUBROUTINE HRADBG

      SUBROUTINE HRADB4(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1,Wa2,Wa3)
      IMPLICIT NONE


      REAL Cc , Ch , sqrt2 , Wa1 , Wa2 , Wa3
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp

!
!     a multiple fft package for spherepack
!
      DIMENSION Cc(Mdimcc,Ido,4,L1) , Ch(Mdimch,Ido,L1,4) , Wa1(Ido) ,  &
              & Wa2(Ido) , Wa3(Ido)
      sqrt2 = SQRT(2.)
      DO k = 1 , L1
         DO 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))
         ENDDO
      ENDDO
      IF ( Ido<2 ) GOTO 99999
      IF ( Ido/=2 ) THEN
         idp2 = Ido + 2
         DO k = 1 , L1
            DO i = 3 , Ido , 2
               ic = idp2 - i
               DO 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)))
               ENDDO
            ENDDO
         ENDDO
         IF ( MOD(Ido,2)==1 ) RETURN
      ENDIF
      DO k = 1 , L1
         DO 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)))
         ENDDO
      ENDDO
99999 END SUBROUTINE HRADB4

      SUBROUTINE HRADB2(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1)
      IMPLICIT NONE
      REAL Cc , Ch , Wa1
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp
!
!     a multiple fft package for spherepack
!
      DIMENSION Cc(Mdimcc,Ido,2,L1) , Ch(Mdimch,Ido,L1,2) , Wa1(Ido)
      DO k = 1 , L1
         DO 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)
         ENDDO
      ENDDO
      IF ( Ido<2 ) GOTO 99999
      IF ( Ido/=2 ) THEN
         idp2 = Ido + 2
         DO k = 1 , L1
            DO i = 3 , Ido , 2
               ic = idp2 - i
               DO 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))
               ENDDO
            ENDDO
         ENDDO
         IF ( MOD(Ido,2)==1 ) RETURN
      ENDIF
      DO k = 1 , L1
         DO 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))
         ENDDO
      ENDDO
99999 END SUBROUTINE HRADB2

      SUBROUTINE HRADB3(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1,Wa2)
      IMPLICIT NONE
      REAL arg , Cc , Ch , PIMACH , taui , taur , Wa1 , Wa2
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp
!
!     a multiple fft package for spherepack
!
      DIMENSION Cc(Mdimcc,Ido,3,L1) , Ch(Mdimch,Ido,L1,3) , Wa1(Ido) ,  &
              & Wa2(Ido)
      arg = 2.*PIMACH()/3.
      taur = COS(arg)
      taui = SIN(arg)
      DO k = 1 , L1
         DO m = 1 , Mp
            Ch(m,1,k,1) = Cc(m,1,1,k) + 2.*Cc(m,Ido,2,k)
            Ch(m,1,k,2) = Cc(m,1,1,k) + (2.*taur)*Cc(m,Ido,2,k)         &
                        & - (2.*taui)*Cc(m,1,3,k)
            Ch(m,1,k,3) = Cc(m,1,1,k) + (2.*taur)*Cc(m,Ido,2,k)         &
                        & + 2.*taui*Cc(m,1,3,k)
         ENDDO
      ENDDO
      IF ( Ido==1 ) RETURN
      idp2 = Ido + 2
      DO k = 1 , L1
         DO i = 3 , Ido , 2
            ic = idp2 - i
            DO 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))))
            ENDDO
         ENDDO
      ENDDO
      END SUBROUTINE HRADB3

      SUBROUTINE HRADB5(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1,Wa2,Wa3,Wa4)
      IMPLICIT NONE
      REAL arg , Cc , Ch , PIMACH , ti11 , ti12 , tr11 , tr12 , Wa1 ,   &
         & Wa2 , Wa3 , Wa4
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp
!
!     a multiple fft package for spherepack
!
      DIMENSION Cc(Mdimcc,Ido,5,L1) , Ch(Mdimch,Ido,L1,5) , Wa1(Ido) ,  &
              & Wa2(Ido) , Wa3(Ido) , Wa4(Ido)
      arg = 2.*PIMACH()/5.
      tr11 = COS(arg)
      ti11 = SIN(arg)
      tr12 = COS(2.*arg)
      ti12 = SIN(2.*arg)
      DO k = 1 , L1
         DO m = 1 , Mp
            Ch(m,1,k,1) = Cc(m,1,1,k) + 2.*Cc(m,Ido,2,k)                &
                        & + 2.*Cc(m,Ido,4,k)
            Ch(m,1,k,2) = (Cc(m,1,1,k)+tr11*2.*Cc(m,Ido,2,k)+tr12*2.*Cc(&
                        & m,Ido,4,k))                                   &
                        & - (ti11*2.*Cc(m,1,3,k)+ti12*2.*Cc(m,1,5,k))
            Ch(m,1,k,3) = (Cc(m,1,1,k)+tr12*2.*Cc(m,Ido,2,k)+tr11*2.*Cc(&
                        & m,Ido,4,k))                                   &
                        & - (ti12*2.*Cc(m,1,3,k)-ti11*2.*Cc(m,1,5,k))
            Ch(m,1,k,4) = (Cc(m,1,1,k)+tr12*2.*Cc(m,Ido,2,k)+tr11*2.*Cc(&
                        & m,Ido,4,k))                                   &
                        & + (ti12*2.*Cc(m,1,3,k)-ti11*2.*Cc(m,1,5,k))
            Ch(m,1,k,5) = (Cc(m,1,1,k)+tr11*2.*Cc(m,Ido,2,k)+tr12*2.*Cc(&
                        & m,Ido,4,k))                                   &
                        & + (ti11*2.*Cc(m,1,3,k)+ti12*2.*Cc(m,1,5,k))
         ENDDO
      ENDDO
      IF ( Ido==1 ) RETURN
      idp2 = Ido + 2
      DO k = 1 , L1
         DO i = 3 , Ido , 2
            ic = idp2 - i
            DO 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))))
            ENDDO
         ENDDO
      ENDDO
      END SUBROUTINE HRADB5

      SUBROUTINE DHRFFTI(N,Wsave)
      IMPLICIT NONE

      INTEGER N
      DOUBLE PRECISION TFFt 
      DOUBLE PRECISION, DIMENSION(N+15) :: Wsave

      COMMON /DHRF   / TFFt
      TFFt = 0.
      IF ( N==1 ) RETURN
      CALL DHRFTI1(N,Wsave(1),Wsave(N+1))
      END SUBROUTINE DHRFFTI

      SUBROUTINE DHRFTI1(N,Wa,Fac)
      IMPLICIT NONE

      DOUBLE PRECISION fi
      DOUBLE PRECISION, DIMENSION(15) :: Fac
      DOUBLE PRECISION, DIMENSION(N) :: Wa
      INTEGER i , ib , ido , ii , ip , ipm , is , j , k1 , l1 , l2 ,    &
            & ld , N , nf , nfm1 , nl , nq , nr , ntry , ntryh
!
!     a multiple fft package for spherepack
!
      DIMENSION ntryh(4)
      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
 100  j = j + 1
      IF ( j<=4 ) THEN
         ntry = ntryh(j)
      ELSE
         ntry = ntry + 2
      ENDIF
 200  nq = nl/ntry
      nr = nl - ntry*nq
      IF ( nr/=0 ) GOTO 100
      nf = nf + 1
      Fac(nf+2) = ntry
      nl = nq
      IF ( ntry==2 ) THEN
         IF ( nf/=1 ) THEN
            DO i = 2 , nf
               ib = nf - i + 2
               Fac(ib+2) = Fac(ib+1)
            ENDDO
            Fac(3) = 2
         ENDIF
      ENDIF
      IF ( nl/=1 ) GOTO 200
      Fac(1) = N
      Fac(2) = nf
      tpi = 8.D0*DATAN(1.D0)
      argh = tpi/FLOAT(N)
      is = 0
      nfm1 = nf - 1
      l1 = 1
      IF ( nfm1==0 ) RETURN
      DO k1 = 1 , nfm1
         ip = Fac(k1+2)
         ld = 0
         l2 = l1*ip
         ido = N/l2
         ipm = ip - 1
         DO j = 1 , ipm
            ld = ld + l1
            i = is
            argld = FLOAT(ld)*argh
            fi = 0.
            DO ii = 3 , ido , 2
               i = i + 2
               fi = fi + 1.
               arg = fi*argld
               Wa(i-1) = DCOS(arg)
               Wa(i) = DSIN(arg)
            ENDDO
            is = is + ido
         ENDDO
         l1 = l2
      ENDDO
      END SUBROUTINE DHRFTI1

      SUBROUTINE DHRFFTF(M,N,R,Mdimr,Whrfft,Work)
      IMPLICIT NONE

      INTEGER M , Mdimr , N
      DOUBLE PRECISION R , TFFt , Whrfft , Work
!
!     a multiple fft package for spherepack
!
      DIMENSION R(Mdimr,N) , Work(1) , Whrfft(N+15)
      COMMON /DHRF   / TFFt
      IF ( N==1 ) RETURN
!     tstart = second(dum)
      CALL DHRFTF1(M,N,R,Mdimr,Work,Whrfft,Whrfft(N+1))
!     tfft = tfft+second(dum)-tstart
      END SUBROUTINE DHRFFTF

      SUBROUTINE DHRFTF1(M,N,C,Mdimc,Ch,Wa,Fac)
      IMPLICIT NONE

      DOUBLE PRECISION C , Ch , Fac , Wa
      INTEGER i , idl1 , ido , ip , iw , ix2 , ix3 , ix4 , j , k1 , kh ,&
            & l1 , l2 , M , Mdimc , N , na , nf
!
!     a multiple fft package for spherepack
!
      DIMENSION Ch(M,N) , C(Mdimc,N) , Wa(N) , Fac(15)
      nf = Fac(2)
      na = 1
      l2 = N
      iw = N
      DO 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==4 ) THEN
            ix2 = iw + ido
            ix3 = ix2 + ido
            IF ( na/=0 ) THEN
               CALL DHRADF4(M,ido,l1,Ch,M,C,Mdimc,Wa(iw),Wa(ix2),Wa(ix3))
            ELSE
               CALL DHRADF4(M,ido,l1,C,Mdimc,Ch,M,Wa(iw),Wa(ix2),Wa(ix3))
            ENDIF
         ELSEIF ( ip/=2 ) THEN
            IF ( ip==3 ) THEN
               ix2 = iw + ido
               IF ( na/=0 ) THEN
                  CALL DHRADF3(M,ido,l1,Ch,M,C,Mdimc,Wa(iw),Wa(ix2))
               ELSE
                  CALL DHRADF3(M,ido,l1,C,Mdimc,Ch,M,Wa(iw),Wa(ix2))
               ENDIF
            ELSEIF ( ip/=5 ) THEN
               IF ( ido==1 ) na = 1 - na
               IF ( na/=0 ) THEN
                  CALL DHRADFG(M,ido,ip,l1,idl1,Ch,Ch,Ch,M,C,C,Mdimc,    &
                            & Wa(iw))
                  na = 0
               ELSE
                  CALL DHRADFG(M,ido,ip,l1,idl1,C,C,C,Mdimc,Ch,Ch,M,     &
                            & Wa(iw))
                  na = 1
               ENDIF
            ELSE
               ix2 = iw + ido
               ix3 = ix2 + ido
               ix4 = ix3 + ido
               IF ( na/=0 ) THEN
                  CALL DHRADF5(M,ido,l1,Ch,M,C,Mdimc,Wa(iw),Wa(ix2),     &
                            & Wa(ix3),Wa(ix4))
               ELSE
                  CALL DHRADF5(M,ido,l1,C,Mdimc,Ch,M,Wa(iw),Wa(ix2),     &
                            & Wa(ix3),Wa(ix4))
               ENDIF
            ENDIF
         ELSEIF ( na/=0 ) THEN
            CALL DHRADF2(M,ido,l1,Ch,M,C,Mdimc,Wa(iw))
         ELSE
            CALL DHRADF2(M,ido,l1,C,Mdimc,Ch,M,Wa(iw))
         ENDIF
         l2 = l1
      ENDDO
      IF ( na==1 ) RETURN
      DO j = 1 , N
         DO i = 1 , M
            C(i,j) = Ch(i,j)
         ENDDO
      ENDDO
      END SUBROUTINE DHRFTF1

      SUBROUTINE DHRADF4(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1,Wa2,Wa3)
      IMPLICIT NONE

      DOUBLE PRECISION Cc , Ch , hsqt2 , Wa1 , Wa2 , Wa3
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp
!
!     a multiple fft package for spherepack
!
      DIMENSION Cc(Mdimcc,Ido,L1,4) , Ch(Mdimch,Ido,4,L1) , Wa1(Ido) ,  &
              & Wa2(Ido) , Wa3(Ido)
      hsqt2 = SQRT(2.)/2.
      DO k = 1 , L1
         DO 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)
         ENDDO
      ENDDO
      IF ( Ido<2 ) GOTO 99999
      IF ( Ido/=2 ) THEN
         idp2 = Ido + 2
         DO k = 1 , L1
            DO i = 3 , Ido , 2
               ic = idp2 - i
               DO 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)))
               ENDDO
            ENDDO
         ENDDO
         IF ( MOD(Ido,2)==1 ) RETURN
      ENDIF
      DO k = 1 , L1
         DO 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)
         ENDDO
      ENDDO
99999 END SUBROUTINE DHRADF4

      SUBROUTINE DHRADF2(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1)
      IMPLICIT NONE

      DOUBLE PRECISION Cc , Ch , Wa1
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp
!
!     a multiple fft package for spherepack
!
      DIMENSION Ch(Mdimch,Ido,2,L1) , Cc(Mdimcc,Ido,L1,2) , Wa1(Ido)
      DO k = 1 , L1
         DO 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)
         ENDDO
      ENDDO
      IF ( Ido<2 ) GOTO 99999
      IF ( Ido/=2 ) THEN
         idp2 = Ido + 2
         DO k = 1 , L1
            DO i = 3 , Ido , 2
               ic = idp2 - i
               DO 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))
               ENDDO
            ENDDO
         ENDDO
         IF ( MOD(Ido,2)==1 ) RETURN
      ENDIF
      DO k = 1 , L1
         DO m = 1 , Mp
            Ch(m,1,2,k) = -Cc(m,Ido,k,2)
            Ch(m,Ido,1,k) = Cc(m,Ido,k,1)
         ENDDO
      ENDDO
99999 END SUBROUTINE DHRADF2

      SUBROUTINE DHRADF3(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1,Wa2)
      IMPLICIT NONE

      DOUBLE PRECISION arg , Cc , Ch , DPIMACH , taui , taur , Wa1 , Wa2
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp
!
!     a multiple fft package for spherepack
!
      DIMENSION Ch(Mdimch,Ido,3,L1) , Cc(Mdimcc,Ido,L1,3) , Wa1(Ido) ,  &
              & Wa2(Ido)
      arg = 2.*DPIMACH()/3.
      taur = COS(arg)
      taui = SIN(arg)
      DO k = 1 , L1
         DO 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))
         ENDDO
      ENDDO
      IF ( Ido==1 ) RETURN
      idp2 = Ido + 2
      DO k = 1 , L1
         DO i = 3 , Ido , 2
            ic = idp2 - i
            DO 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))))
            ENDDO
         ENDDO
      ENDDO
      END SUBROUTINE DHRADF3

      SUBROUTINE DHRADF5(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1,Wa2,Wa3,Wa4)
      IMPLICIT NONE
      DOUBLE PRECISION arg , Cc , Ch , DPIMACH , ti11 , ti12 , tr11 , tr12 , Wa1 ,   &
         & Wa2 , Wa3 , Wa4
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp
!
!     a multiple fft package for spherepack
!
      DIMENSION Cc(Mdimcc,Ido,L1,5) , Ch(Mdimch,Ido,5,L1) , Wa1(Ido) ,  &
              & Wa2(Ido) , Wa3(Ido) , Wa4(Ido)
      arg = 2.*DPIMACH()/5.
      tr11 = COS(arg)
      ti11 = SIN(arg)
      tr12 = COS(2.*arg)
      ti12 = SIN(2.*arg)
      DO k = 1 , L1
         DO 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))
         ENDDO
      ENDDO
      IF ( Ido==1 ) RETURN
      idp2 = Ido + 2
      DO k = 1 , L1
         DO i = 3 , Ido , 2
            ic = idp2 - i
            DO 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))))
            ENDDO
         ENDDO
      ENDDO
      END SUBROUTINE DHRADF5

      SUBROUTINE DHRADFG(Mp,Ido,Ip,L1,Idl1,Cc,C1,C2,Mdimcc,Ch,Ch2,Mdimch,&
                      & Wa)
      IMPLICIT NONE
      DOUBLE PRECISION ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , C1 , C2 , Cc ,   &
         & Ch , Ch2 , dc2 , dcp , ds2 , dsp , DPIMACH , tpi , Wa
      INTEGER i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 ,      &
            & ipph , is , j , j2 , jc , k , l , L1 , lc , m , Mdimcc
      INTEGER Mdimch , Mp , nbd
!
!     a multiple fft package for spherepack
!
      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.*DPIMACH()
      arg = tpi/FLOAT(Ip)
      dcp = COS(arg)
      dsp = SIN(arg)
      ipph = (Ip+1)/2
      ipp2 = Ip + 2
      idp2 = Ido + 2
      nbd = (Ido-1)/2
      IF ( Ido==1 ) THEN
         DO ik = 1 , Idl1
            DO m = 1 , Mp
               C2(m,ik,1) = Ch2(m,ik,1)
            ENDDO
         ENDDO
      ELSE
         DO ik = 1 , Idl1
            DO m = 1 , Mp
               Ch2(m,ik,1) = C2(m,ik,1)
            ENDDO
         ENDDO
         DO j = 2 , Ip
            DO k = 1 , L1
               DO m = 1 , Mp
                  Ch(m,1,k,j) = C1(m,1,k,j)
               ENDDO
            ENDDO
         ENDDO
         IF ( nbd>L1 ) THEN
            is = -Ido
            DO j = 2 , Ip
               is = is + Ido
               DO k = 1 , L1
                  idij = is
                  DO i = 3 , Ido , 2
                     idij = idij + 2
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ELSE
            is = -Ido
            DO j = 2 , Ip
               is = is + Ido
               idij = is
               DO i = 3 , Ido , 2
                  idij = idij + 2
                  DO k = 1 , L1
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
         IF ( nbd<L1 ) THEN
            DO j = 2 , ipph
               jc = ipp2 - j
               DO i = 3 , Ido , 2
                  DO k = 1 , L1
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ELSE
            DO j = 2 , ipph
               jc = ipp2 - j
               DO k = 1 , L1
                  DO i = 3 , Ido , 2
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      DO j = 2 , ipph
         jc = ipp2 - j
         DO k = 1 , L1
            DO 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)
            ENDDO
         ENDDO
      ENDDO
!
      ar1 = 1.
      ai1 = 0.
      DO l = 2 , ipph
         lc = ipp2 - l
         ar1h = dcp*ar1 - dsp*ai1
         ai1 = dcp*ai1 + dsp*ar1
         ar1 = ar1h
         DO ik = 1 , Idl1
            DO 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)
            ENDDO
         ENDDO
         dc2 = ar1
         ds2 = ai1
         ar2 = ar1
         ai2 = ai1
         DO j = 3 , ipph
            jc = ipp2 - j
            ar2h = dc2*ar2 - ds2*ai2
            ai2 = dc2*ai2 + ds2*ar2
            ar2 = ar2h
            DO ik = 1 , Idl1
               DO 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)
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      DO j = 2 , ipph
         DO ik = 1 , Idl1
            DO m = 1 , Mp
               Ch2(m,ik,1) = Ch2(m,ik,1) + C2(m,ik,j)
            ENDDO
         ENDDO
      ENDDO
!
      IF ( Ido<L1 ) THEN
         DO i = 1 , Ido
            DO k = 1 , L1
               DO m = 1 , Mp
                  Cc(m,i,1,k) = Ch(m,i,k,1)
               ENDDO
            ENDDO
         ENDDO
      ELSE
         DO k = 1 , L1
            DO i = 1 , Ido
               DO m = 1 , Mp
                  Cc(m,i,1,k) = Ch(m,i,k,1)
               ENDDO
            ENDDO
         ENDDO
      ENDIF
      DO j = 2 , ipph
         jc = ipp2 - j
         j2 = j + j
         DO k = 1 , L1
            DO 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)
            ENDDO
         ENDDO
      ENDDO
      IF ( Ido==1 ) RETURN
      IF ( nbd<L1 ) THEN
         DO j = 2 , ipph
            jc = ipp2 - j
            j2 = j + j
            DO i = 3 , Ido , 2
               ic = idp2 - i
               DO k = 1 , L1
                  DO 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)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
         GOTO 99999
      ENDIF
      DO j = 2 , ipph
         jc = ipp2 - j
         j2 = j + j
         DO k = 1 , L1
            DO i = 3 , Ido , 2
               ic = idp2 - i
               DO 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)
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      RETURN
99999 END SUBROUTINE  DHRADFG


      SUBROUTINE DHRFFTB(M,N,R,Mdimr,Whrfft,Work)
      IMPLICIT NONE
      INTEGER M , Mdimr , N
      DOUBLE PRECISION R , TFFt , Whrfft , Work
!
!     a multiple fft package for spherepack
!
      DIMENSION R(Mdimr,N) , Work(1) , Whrfft(N+15)
      COMMON /DHRF   / TFFt
      IF ( N==1 ) RETURN
!     tstart = second(dum)
      CALL DHRFTB1(M,N,R,Mdimr,Work,Whrfft,Whrfft(N+1))
!     tfft = tfft+second(dum)-tstart
      END SUBROUTINE DHRFFTB

      SUBROUTINE DHRFTB1(M,N,C,Mdimc,Ch,Wa,Fac)
      IMPLICIT NONE
      DOUBLE PRECISION C , Ch , Fac , Wa
      INTEGER i , idl1 , ido , ip , iw , ix2 , ix3 , ix4 , j , k1 , l1 ,&
            & l2 , M , Mdimc , N , na , nf
!
!     a multiple fft package for spherepack
!
      DIMENSION Ch(M,N) , C(Mdimc,N) , Wa(N) , Fac(15)
      nf = Fac(2)
      na = 0
      l1 = 1
      iw = 1
      DO k1 = 1 , nf
         ip = Fac(k1+2)
         l2 = ip*l1
         ido = N/l2
         idl1 = ido*l1
         IF ( ip==4 ) THEN
            ix2 = iw + ido
            ix3 = ix2 + ido
            IF ( na/=0 ) THEN
               CALL DHRADB4(M,ido,l1,Ch,M,C,Mdimc,Wa(iw),Wa(ix2),Wa(ix3))
            ELSE
               CALL DHRADB4(M,ido,l1,C,Mdimc,Ch,M,Wa(iw),Wa(ix2),Wa(ix3))
            ENDIF
            na = 1 - na
         ELSEIF ( ip==2 ) THEN
            IF ( na/=0 ) THEN
               CALL DHRADB2(M,ido,l1,Ch,M,C,Mdimc,Wa(iw))
            ELSE
               CALL DHRADB2(M,ido,l1,C,Mdimc,Ch,M,Wa(iw))
            ENDIF
            na = 1 - na
         ELSEIF ( ip==3 ) THEN
            ix2 = iw + ido
            IF ( na/=0 ) THEN
               CALL DHRADB3(M,ido,l1,Ch,M,C,Mdimc,Wa(iw),Wa(ix2))
            ELSE
               CALL DHRADB3(M,ido,l1,C,Mdimc,Ch,M,Wa(iw),Wa(ix2))
            ENDIF
            na = 1 - na
         ELSEIF ( ip/=5 ) THEN
            IF ( na/=0 ) THEN
               CALL DHRADBG(M,ido,ip,l1,idl1,Ch,Ch,Ch,M,C,C,Mdimc,Wa(iw))
            ELSE
               CALL DHRADBG(M,ido,ip,l1,idl1,C,C,C,Mdimc,Ch,Ch,M,Wa(iw))
            ENDIF
            IF ( ido==1 ) na = 1 - na
         ELSE
            ix2 = iw + ido
            ix3 = ix2 + ido
            ix4 = ix3 + ido
            IF ( na/=0 ) THEN
               CALL DHRADB5(M,ido,l1,Ch,M,C,Mdimc,Wa(iw),Wa(ix2),Wa(ix3),&
                         & Wa(ix4))
            ELSE
               CALL DHRADB5(M,ido,l1,C,Mdimc,Ch,M,Wa(iw),Wa(ix2),Wa(ix3),&
                         & Wa(ix4))
            ENDIF
            na = 1 - na
         ENDIF
         l1 = l2
         iw = iw + (ip-1)*ido
      ENDDO
      IF ( na==0 ) RETURN
      DO j = 1 , N
         DO i = 1 , M
            C(i,j) = Ch(i,j)
         ENDDO
      ENDDO
      END SUBROUTINE DHRFTB1

      SUBROUTINE DHRADBG(Mp,Ido,Ip,L1,Idl1,Cc,C1,C2,Mdimcc,Ch,Ch2,Mdimch,&
                      & Wa)
      IMPLICIT NONE
      DOUBLE PRECISION ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , C1 , C2 , Cc ,   &
         & Ch , Ch2 , dc2 , dcp , ds2 , dsp , DPIMACH , tpi , Wa
      INTEGER i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 ,      &
            & ipph , is , j , j2 , jc , k , l , L1 , lc , m , Mdimcc
      INTEGER Mdimch , Mp , nbd
!
!     a multiple fft package for spherepack
!
      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.*DPIMACH()
      arg = tpi/FLOAT(Ip)
      dcp = COS(arg)
      dsp = SIN(arg)
      idp2 = Ido + 2
      nbd = (Ido-1)/2
      ipp2 = Ip + 2
      ipph = (Ip+1)/2
      IF ( Ido<L1 ) THEN
         DO i = 1 , Ido
            DO k = 1 , L1
               DO m = 1 , Mp
                  Ch(m,i,k,1) = Cc(m,i,1,k)
               ENDDO
            ENDDO
         ENDDO
      ELSE
         DO k = 1 , L1
            DO i = 1 , Ido
               DO m = 1 , Mp
                  Ch(m,i,k,1) = Cc(m,i,1,k)
               ENDDO
            ENDDO
         ENDDO
      ENDIF
      DO j = 2 , ipph
         jc = ipp2 - j
         j2 = j + j
         DO k = 1 , L1
            DO 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)
            ENDDO
         ENDDO
      ENDDO
      IF ( Ido/=1 ) THEN
         IF ( nbd<L1 ) THEN
            DO j = 2 , ipph
               jc = ipp2 - j
               DO i = 3 , Ido , 2
                  ic = idp2 - i
                  DO k = 1 , L1
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ELSE
            DO j = 2 , ipph
               jc = ipp2 - j
               DO k = 1 , L1
                  DO i = 3 , Ido , 2
                     ic = idp2 - i
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      ar1 = 1.
      ai1 = 0.
      DO l = 2 , ipph
         lc = ipp2 - l
         ar1h = dcp*ar1 - dsp*ai1
         ai1 = dcp*ai1 + dsp*ar1
         ar1 = ar1h
         DO ik = 1 , Idl1
            DO 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)
            ENDDO
         ENDDO
         dc2 = ar1
         ds2 = ai1
         ar2 = ar1
         ai2 = ai1
         DO j = 3 , ipph
            jc = ipp2 - j
            ar2h = dc2*ar2 - ds2*ai2
            ai2 = dc2*ai2 + ds2*ar2
            ar2 = ar2h
            DO ik = 1 , Idl1
               DO 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)
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      DO j = 2 , ipph
         DO ik = 1 , Idl1
            DO m = 1 , Mp
               Ch2(m,ik,1) = Ch2(m,ik,1) + Ch2(m,ik,j)
            ENDDO
         ENDDO
      ENDDO
      DO j = 2 , ipph
         jc = ipp2 - j
         DO k = 1 , L1
            DO 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)
            ENDDO
         ENDDO
      ENDDO
      IF ( Ido/=1 ) THEN
         IF ( nbd<L1 ) THEN
            DO j = 2 , ipph
               jc = ipp2 - j
               DO i = 3 , Ido , 2
                  DO k = 1 , L1
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ELSE
            DO j = 2 , ipph
               jc = ipp2 - j
               DO k = 1 , L1
                  DO i = 3 , Ido , 2
                     DO 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)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      IF ( Ido==1 ) RETURN
      DO ik = 1 , Idl1
         DO m = 1 , Mp
            C2(m,ik,1) = Ch2(m,ik,1)
         ENDDO
      ENDDO
      DO j = 2 , Ip
         DO k = 1 , L1
            DO m = 1 , Mp
               C1(m,1,k,j) = Ch(m,1,k,j)
            ENDDO
         ENDDO
      ENDDO
      IF ( nbd>L1 ) THEN
         is = -Ido
         DO j = 2 , Ip
            is = is + Ido
            DO k = 1 , L1
               idij = is
               DO i = 3 , Ido , 2
                  idij = idij + 2
                  DO 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)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ELSE
         is = -Ido
         DO j = 2 , Ip
            is = is + Ido
            idij = is
            DO i = 3 , Ido , 2
               idij = idij + 2
               DO k = 1 , L1
                  DO 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)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDIF
      END SUBROUTINE DHRADBG

      SUBROUTINE DHRADB4(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1,Wa2,Wa3)
      IMPLICIT NONE

      DOUBLE PRECISION Cc , Ch , sqrt2 , Wa1 , Wa2 , Wa3
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp

!
!     a multiple fft package for spherepack
!
      DIMENSION Cc(Mdimcc,Ido,4,L1) , Ch(Mdimch,Ido,L1,4) , Wa1(Ido) ,  &
              & Wa2(Ido) , Wa3(Ido)
      sqrt2 = SQRT(2.)
      DO k = 1 , L1
         DO 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))
         ENDDO
      ENDDO
      IF ( Ido<2 ) GOTO 99999
      IF ( Ido/=2 ) THEN
         idp2 = Ido + 2
         DO k = 1 , L1
            DO i = 3 , Ido , 2
               ic = idp2 - i
               DO 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)))
               ENDDO
            ENDDO
         ENDDO
         IF ( MOD(Ido,2)==1 ) RETURN
      ENDIF
      DO k = 1 , L1
         DO 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)))
         ENDDO
      ENDDO
99999 END SUBROUTINE DHRADB4

      SUBROUTINE DHRADB2(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1)
      IMPLICIT NONE
      DOUBLE PRECISION Cc , Ch , Wa1
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp
!
!     a multiple fft package for spherepack
!
      DIMENSION Cc(Mdimcc,Ido,2,L1) , Ch(Mdimch,Ido,L1,2) , Wa1(Ido)
      DO k = 1 , L1
         DO 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)
         ENDDO
      ENDDO
      IF ( Ido<2 ) GOTO 99999
      IF ( Ido/=2 ) THEN
         idp2 = Ido + 2
         DO k = 1 , L1
            DO i = 3 , Ido , 2
               ic = idp2 - i
               DO 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))
               ENDDO
            ENDDO
         ENDDO
         IF ( MOD(Ido,2)==1 ) RETURN
      ENDIF
      DO k = 1 , L1
         DO 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))
         ENDDO
      ENDDO
99999 END SUBROUTINE DHRADB2

      SUBROUTINE DHRADB3(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1,Wa2)
      IMPLICIT NONE
      DOUBLE PRECISION arg , Cc , Ch , DPIMACH , taui , taur , Wa1 , Wa2
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp
!
!     a multiple fft package for spherepack
!
      DIMENSION Cc(Mdimcc,Ido,3,L1) , Ch(Mdimch,Ido,L1,3) , Wa1(Ido) ,  &
              & Wa2(Ido)
      arg = 2.*DPIMACH()/3.
      taur = COS(arg)
      taui = SIN(arg)
      DO k = 1 , L1
         DO m = 1 , Mp
            Ch(m,1,k,1) = Cc(m,1,1,k) + 2.*Cc(m,Ido,2,k)
            Ch(m,1,k,2) = Cc(m,1,1,k) + (2.*taur)*Cc(m,Ido,2,k)         &
                        & - (2.*taui)*Cc(m,1,3,k)
            Ch(m,1,k,3) = Cc(m,1,1,k) + (2.*taur)*Cc(m,Ido,2,k)         &
                        & + 2.*taui*Cc(m,1,3,k)
         ENDDO
      ENDDO
      IF ( Ido==1 ) RETURN
      idp2 = Ido + 2
      DO k = 1 , L1
         DO i = 3 , Ido , 2
            ic = idp2 - i
            DO 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))))
            ENDDO
         ENDDO
      ENDDO
      END SUBROUTINE DHRADB3

      SUBROUTINE DHRADB5(Mp,Ido,L1,Cc,Mdimcc,Ch,Mdimch,Wa1,Wa2,Wa3,Wa4)
      IMPLICIT NONE
      DOUBLE PRECISION arg , Cc , Ch , DPIMACH , ti11 , ti12 , tr11 , tr12 , Wa1 ,   &
         & Wa2 , Wa3 , Wa4
      INTEGER i , ic , Ido , idp2 , k , L1 , m , Mdimcc , Mdimch , Mp
!
!     a multiple fft package for spherepack
!
      DIMENSION Cc(Mdimcc,Ido,5,L1) , Ch(Mdimch,Ido,L1,5) , Wa1(Ido) ,  &
              & Wa2(Ido) , Wa3(Ido) , Wa4(Ido)
      arg = 2.*DPIMACH()/5.
      tr11 = COS(arg)
      ti11 = SIN(arg)
      tr12 = COS(2.*arg)
      ti12 = SIN(2.*arg)
      DO k = 1 , L1
         DO m = 1 , Mp
            Ch(m,1,k,1) = Cc(m,1,1,k) + 2.*Cc(m,Ido,2,k)                &
                        & + 2.*Cc(m,Ido,4,k)
            Ch(m,1,k,2) = (Cc(m,1,1,k)+tr11*2.*Cc(m,Ido,2,k)+tr12*2.*Cc(&
                        & m,Ido,4,k))                                   &
                        & - (ti11*2.*Cc(m,1,3,k)+ti12*2.*Cc(m,1,5,k))
            Ch(m,1,k,3) = (Cc(m,1,1,k)+tr12*2.*Cc(m,Ido,2,k)+tr11*2.*Cc(&
                        & m,Ido,4,k))                                   &
                        & - (ti12*2.*Cc(m,1,3,k)-ti11*2.*Cc(m,1,5,k))
            Ch(m,1,k,4) = (Cc(m,1,1,k)+tr12*2.*Cc(m,Ido,2,k)+tr11*2.*Cc(&
                        & m,Ido,4,k))                                   &
                        & + (ti12*2.*Cc(m,1,3,k)-ti11*2.*Cc(m,1,5,k))
            Ch(m,1,k,5) = (Cc(m,1,1,k)+tr11*2.*Cc(m,Ido,2,k)+tr12*2.*Cc(&
                        & m,Ido,4,k))                                   &
                        & + (ti11*2.*Cc(m,1,3,k)+ti12*2.*Cc(m,1,5,k))
         ENDDO
      ENDDO
      IF ( Ido==1 ) RETURN
      idp2 = Ido + 2
      DO k = 1 , L1
         DO i = 3 , Ido , 2
            ic = idp2 - i
            DO 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))))
            ENDDO
         ENDDO
      ENDDO
      END SUBROUTINE DHRADB5
