!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         SPHEREPACK3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
!
!     file alf.f contains subroutines alfk,lfim,lfim1,lfin,lfin1,lfpt
!     for computing normalized associated legendre polynomials
!
! subroutine alfk (n,m,cp)
!
! dimension of           real cp(n/2 + mod(n,2))
! arguments
!
! purpose                routine alfk computes single precision fourier
!                        coefficients in the trigonometric series
!                        representation of the normalized associated
!                        legendre function pbar(n,m,theta) for use by
!                        routines lfp and lfpt in calculating single
!                        precision pbar(n,m,theta).
!
!                        first define the normalized associated
!                        legendre functions
!
!                        pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
!                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
!                        factorial(n)) times the (n+m)th derivative of
!                        (x**2-1)**n with respect to x=cos(theta)
!
!                        where theta is colatitude.
!
!                        then subroutine alfk computes the coefficients
!                        cp(k) in the following trigonometric
!                        expansion of pbar(m,n,theta).
!
!                        1) for n even and m even, pbar(m,n,theta) =
!                           .5*cp(1) plus the sum from k=1 to k=n/2
!                           of cp(k)*cos(2*k*th)
!
!                        2) for n even and m odd, pbar(m,n,theta) =
!                           the sum from k=1 to k=n/2 of
!                           cp(k)*sin(2*k*th)
!
!                        3) for n odd and m even, pbar(m,n,theta) =
!                           the sum from k=1 to k=(n+1)/2 of
!                           cp(k)*cos((2*k-1)*th)
!
!                        4) for n odd and m odd,  pbar(m,n,theta) =
!                           the sum from k=1 to k=(n+1)/2 of
!                           cp(k)*sin((2*k-1)*th)
!
!
! usage                  call alfk(n,m,cp)
!
! arguments
!
! on input               n
!                          nonnegative integer specifying the degree of
!                          pbar(n,m,theta)
!
!                        m
!                          is the order of pbar(n,m,theta). m can be
!                          any integer however cp is computed such that
!                          pbar(n,m,theta) = 0 if abs(m) is greater
!                          than n and pbar(n,m,theta) = (-1)**m*
!                          pbar(n,-m,theta) for negative m.
!
! on output              cp
!                          single precision array of length (n/2)+1
!                          which contains the fourier coefficients in
!                          the trigonometric series representation of
!                          pbar(n,m,theta)
!
!
! special conditions     none
!
! precision              single
!
! algorithm              the highest order coefficient is determined in
!                        closed form and the remainig coefficients are
!                        determined as the solution of a backward
!                        recurrence relation.
!
! accuracy               comparison between routines alfk and double
!                        precision dalfk on the cray1 indicates
!                        greater accuracy for smaller values
!                        of input parameter n.  agreement to 14
!                        places was obtained for n=10 and to 13
!                        places for n=100.
!
      SUBROUTINE ALFK(N,M,Cp)
      IMPLICIT NONE
      REAL a1 , b1 , c1 ,  cp2 , fden , fk , fnmh , fnmsq , fnnp1 , &
           & fnum , pm1  , t1 , t2
      REAL, DIMENSION(N/2+1) :: Cp
      INTEGER i , l , M , ma , N , nex , nmms2

      REAL, PARAMETER :: SC10=1024.
      REAL, PARAMETER :: SC20=SC10*SC10
      REAL, PARAMETER :: SC40=SC20*SC20

      Cp(1) = 0.
      ma = IABS(M)
      IF ( ma.GT.N ) RETURN
      IF ( N.LT.1 ) THEN
         Cp(1) = SQRT(2.)
         RETURN
      ELSEIF ( N.EQ.1 ) THEN
         IF ( ma.NE.0 ) THEN
            Cp(1) = SQRT(.75)
            IF ( M.EQ.-1 ) Cp(1) = -Cp(1)
            RETURN
         ELSE
            Cp(1) = SQRT(1.5)
            RETURN
         ENDIF
      ELSE
         IF ( MOD(N+ma,2).NE.0 ) THEN
            nmms2 = (N-ma-1)/2
            fnum = N + ma + 2
            fnmh = N - ma + 2
            pm1 = -1.
         ELSE
            nmms2 = (N-ma)/2
            fnum = N + ma + 1
            fnmh = N - ma + 1
            pm1 = 1.
         ENDIF
         t1 = 1./SC20
         nex = 20
         fden = 2.
         IF ( nmms2.GE.1 ) THEN
            DO i = 1 , nmms2
               t1 = fnum*t1/fden
               IF ( t1.GT.SC20 ) THEN
                  t1 = t1/SC40
                  nex = nex + 40
               ENDIF
               fnum = fnum + 2.
               fden = fden + 2.
            ENDDO
         ENDIF
         t1 = t1/2.**(N-1-nex)
         IF ( MOD(ma/2,2).NE.0 ) t1 = -t1
         t2 = 1.
         IF ( ma.NE.0 ) THEN
            DO i = 1 , ma
               t2 = fnmh*t2/(fnmh+pm1)
               fnmh = fnmh + 2.
            ENDDO
         ENDIF
         cp2 = t1*SQRT((N+.5)*t2)
         fnnp1 = N*(N+1)
         fnmsq = fnnp1 - 2.*ma*ma
         l = (N+1)/2
         IF ( MOD(N,2).EQ.0 .AND. MOD(ma,2).EQ.0 ) l = l + 1
         Cp(l) = cp2
         IF ( M.LT.0 ) THEN
            IF ( MOD(ma,2).NE.0 ) Cp(l) = -Cp(l)
         ENDIF
         IF ( l.LE.1 ) RETURN
         fk = N
         a1 = (fk-2.)*(fk-1.) - fnnp1
         b1 = 2.*(fk*fk-fnmsq)
         Cp(l-1) = b1*Cp(l)/a1
 50      l = l - 1
         IF ( l.LE.1 ) RETURN
         fk = fk - 2.
         a1 = (fk-2.)*(fk-1.) - fnnp1
         b1 = -2.*(fk*fk-fnmsq)
         c1 = (fk+1.)*(fk+2.) - fnnp1
         Cp(l-1) = -(b1*Cp(l)+c1*Cp(l+1))/a1
         GOTO 50
      ENDIF
      END SUBROUTINE ALFK

      
      SUBROUTINE DALFK(N,M,Cp)
      IMPLICIT NONE
      DOUBLE PRECISION  a1 , b1 , c1 ,  cp2 , fden , fk , fnmh , fnmsq , fnnp1 , &
           & fnum , pm1 , SC10 , SC20 , SC40 , t1 , t2
      DOUBLE PRECISION, DIMENSION(N/2+1) :: Cp
      INTEGER i , l , M , ma , N , nex , nmms2

      PARAMETER (SC10=1024.)
      PARAMETER (SC20=SC10*SC10)
      PARAMETER (SC40=SC20*SC20)
!
      Cp(1) = 0.
      ma = IABS(M)
      IF ( ma.GT.N ) RETURN
      IF ( N.LT.1 ) THEN
         Cp(1) = SQRT(2.)
         RETURN
      ELSEIF ( N.EQ.1 ) THEN
         IF ( ma.NE.0 ) THEN
            Cp(1) = SQRT(.75)
            IF ( M.EQ.-1 ) Cp(1) = -Cp(1)
            RETURN
         ELSE
            Cp(1) = SQRT(1.5)
            RETURN
         ENDIF
      ELSE
         IF ( MOD(N+ma,2).NE.0 ) THEN
            nmms2 = (N-ma-1)/2
            fnum = N + ma + 2
            fnmh = N - ma + 2
            pm1 = -1.
         ELSE
            nmms2 = (N-ma)/2
            fnum = N + ma + 1
            fnmh = N - ma + 1
            pm1 = 1.
         ENDIF
         t1 = 1./SC20
         nex = 20
         fden = 2.
         IF ( nmms2.GE.1 ) THEN
            DO i = 1 , nmms2
               t1 = fnum*t1/fden
               IF ( t1.GT.SC20 ) THEN
                  t1 = t1/SC40
                  nex = nex + 40
               ENDIF
               fnum = fnum + 2.
               fden = fden + 2.
            ENDDO
         ENDIF
         t1 = t1/2.**(N-1-nex)
         IF ( MOD(ma/2,2).NE.0 ) t1 = -t1
         t2 = 1.
         IF ( ma.NE.0 ) THEN
            DO i = 1 , ma
               t2 = fnmh*t2/(fnmh+pm1)
               fnmh = fnmh + 2.
            ENDDO
         ENDIF
         cp2 = t1*SQRT((N+.5)*t2)
         fnnp1 = N*(N+1)
         fnmsq = fnnp1 - 2.*ma*ma
         l = (N+1)/2
         IF ( MOD(N,2).EQ.0 .AND. MOD(ma,2).EQ.0 ) l = l + 1
         Cp(l) = cp2
         IF ( M.LT.0 ) THEN
            IF ( MOD(ma,2).NE.0 ) Cp(l) = -Cp(l)
         ENDIF
         IF ( l.LE.1 ) RETURN
         fk = N
         a1 = (fk-2.)*(fk-1.) - fnnp1
         b1 = 2.*(fk*fk-fnmsq)
         Cp(l-1) = b1*Cp(l)/a1
 50      l = l - 1
         IF ( l.LE.1 ) RETURN
         fk = fk - 2.
         a1 = (fk-2.)*(fk-1.) - fnnp1
         b1 = -2.*(fk*fk-fnmsq)
         c1 = (fk+1.)*(fk+2.) - fnnp1
         Cp(l-1) = -(b1*Cp(l)+c1*Cp(l+1))/a1
         GOTO 50
      ENDIF
      END SUBROUTINE DALFK

! subroutine lfim (init,theta,l,n,nm,pb,id,wlfim)
!
! dimension of           theta(l),  pb(id,nm+1),  wlfim(4*l*(nm+1))
! arguments
!
! purpose                given n and l, routine lfim calculates
!                        the normalized associated legendre functions
!                        pbar(n,m,theta) for m=0,...,n and theta(i)
!                        for i=1,...,l where
!
!                        pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
!                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
!                        factorial(n)) times the (n+m)th derivative of
!                        (x**2-1)**n with respect to x=cos(theta)
!
! usage                  call lfim (init,theta,l,n,nm,pb,id,wlfim)
!
! arguments
! on input               init
!                        = 0
!                            initialization only - using parameters
!                            l, nm and array theta, subroutine lfim
!                            initializes array wlfim for subsequent
!                            use in the computation of the associated
!                            legendre functions pb. initialization
!                            does not have to be repeated unless
!                            l, nm, or array theta are changed.
!                        = 1
!                            subroutine lfim uses the array wlfim that
!                            was computed with init = 0 to compute pb.
!
!                        theta
!                          an array that contains the colatitudes
!                          at which the associated legendre functions
!                          will be computed. the colatitudes must be
!                          specified in radians.
!
!                        l
!                          the length of the theta array. lfim is
!                          vectorized with vector length l.
!
!                        n
!                          nonnegative integer, less than nm, specifying
!                          degree of pbar(n,m,theta). subroutine lfim
!                          must be called starting with n=0. n must be
!                          incremented by one in subsequent calls and
!                          must not exceed nm.
!
!                        nm
!                          the maximum value of n and m
!
!                        id
!                          the first dimension of the two dimensional
!                          array pb as it appears in the program that
!                          calls lfim. (see output parameter pb)
!
!                        wlfim
!                          an array with length 4*l*(nm+1) which
!                          must be initialized by calling lfim
!                          with init=0 (see parameter init)  it
!                          must not be altered between calls to
!                          lfim.
!
!
! on output              pb
!                          a two dimensional array with first
!                          dimension id in the program that calls
!                          lfim. the second dimension of pb must
!                          be at least nm+1. starting with n=0
!                          lfim is called repeatedly with n being
!                          increased by one between calls. on each
!                          call, subroutine lfim computes
!                          = pbar(m,n,theta(i)) for m=0,...,n and
!                          i=1,...l.
!
!                        wlfim
!                          array containing values which must not
!                          be altered unless l, nm or the array theta
!                          are changed in which case lfim must be
!                          called with init=0 to reinitialize the
!                          wlfim array.
!
! special conditions     n must be increased by one between calls
!                        of lfim in which n is not zero.
!
! precision              single
!
!
! algorithm              routine lfim calculates pbar(n,m,theta) using
!                        a four term recurrence relation. (unpublished
!                        notes by paul n. swarztrauber)
!
      SUBROUTINE LFIM(Init,Theta,L,N,Nm,Pb,Id,Wlfim)
      IMPLICIT NONE
!*--LFIM284

      INTEGER Id , Init , iw1 , iw2 , iw3 , L , lnx , N , Nm
      REAL :: Theta
      REAL, DIMENSION(1) :: Pb, Wlfim

!
!     total length of wlfim is 4*l*(nm+1)
!
      lnx = L*(Nm+1)
      iw1 = lnx + 1
      iw2 = iw1 + lnx
      iw3 = iw2 + lnx
      CALL LFIM1(Init,Theta,L,N,Nm,Id,Pb,Wlfim,Wlfim(iw1),Wlfim(iw2),   &
               & Wlfim(iw3),Wlfim(iw2))
    END SUBROUTINE LFIM

    
    SUBROUTINE DLFIM(Init,Theta,L,N,Nm,Pb,Id,Wlfim)
      IMPLICIT NONE
!*--LFIM284

      INTEGER Id , Init , iw1 , iw2 , iw3 , L , lnx , N , Nm
      DOUBLE PRECISION :: Theta
      DOUBLE PRECISION, DIMENSION(1) :: Pb, Wlfim

!
!     total length of wlfim is 4*l*(nm+1)
!
      lnx = L*(Nm+1)
      iw1 = lnx + 1
      iw2 = iw1 + lnx
      iw3 = iw2 + lnx
      CALL DLFIM1(Init,Theta,L,N,Nm,Id,Pb,Wlfim,Wlfim(iw1),Wlfim(iw2),   &
               & Wlfim(iw3),Wlfim(iw2))
    END SUBROUTINE DLFIM

      
    SUBROUTINE LFIM1(Init,Theta,L,N,Nm,Id,P3,Phz,Ph1,P1,P2,Cp)
      IMPLICIT NONE

      REAL cc , cn , dd , ee , fm , fn , fnmm , fnpm  ,   &
         &    sq1s6 , sq5s6 , ssqrt2 , temp ,  tn
      INTEGER i , Id , Init , L , m , mp1 , N , nh , Nm , nm1 , nmp1 ,  &
            & np1

      REAL, DIMENSION(L,1) :: P1, P2, Ph1, Phz
      REAL, DIMENSION(1)   :: Cp, Theta
      REAL, DIMENSION(Id, 1) :: P3
      nmp1 = Nm + 1
      IF ( Init.EQ.0 ) THEN
         ssqrt2 = 1./SQRT(2.)
         DO i = 1 , L
            Phz(i,1) = ssqrt2
         ENDDO
         DO np1 = 2 , nmp1
            nh = np1 - 1
            CALL ALFK(nh,0,Cp)
            DO i = 1 , L
               CALL LFPT(nh,0,Theta(i),Cp,Phz(i,np1))
            ENDDO
            CALL ALFK(nh,1,Cp)
            DO i = 1 , L
               CALL LFPT(nh,1,Theta(i),Cp,Ph1(i,np1))
            ENDDO
         ENDDO
         RETURN
      ELSEIF ( N.GT.2 ) THEN
         nm1 = N - 1
         np1 = N + 1
         fn = FLOAT(N)
         tn = fn + fn
         cn = (tn+1.)/(tn-3.)
         DO i = 1 , L
            P3(i,1) = Phz(i,np1)
            P3(i,2) = Ph1(i,np1)
         ENDDO
         IF ( nm1.GE.3 ) THEN
            DO mp1 = 3 , nm1
               m = mp1 - 1
               fm = FLOAT(m)
               fnpm = fn + fm
               fnmm = fn - fm
               temp = fnpm*(fnpm-1.)
               cc = SQRT(cn*(fnpm-3.)*(fnpm-2.)/temp)
               dd = SQRT(cn*fnmm*(fnmm-1.)/temp)
               ee = SQRT((fnmm+1.)*(fnmm+2.)/temp)
               DO i = 1 , L
                  P3(i,mp1) = cc*P1(i,mp1-2) + dd*P1(i,mp1)             &
                            & - ee*P3(i,mp1-2)
               ENDDO
            ENDDO
         ENDIF
         fnpm = fn + fn - 1.
         temp = fnpm*(fnpm-1.)
         cc = SQRT(cn*(fnpm-3.)*(fnpm-2.)/temp)
         ee = SQRT(6./temp)
         DO i = 1 , L
            P3(i,N) = cc*P1(i,N-2) - ee*P3(i,N-2)
         ENDDO
         fnpm = fn + fn
         temp = fnpm*(fnpm-1.)
         cc = SQRT(cn*(fnpm-3.)*(fnpm-2.)/temp)
         ee = SQRT(2./temp)
         DO i = 1 , L
            P3(i,N+1) = cc*P1(i,N-1) - ee*P3(i,N-1)
         ENDDO
         DO mp1 = 1 , np1
            DO i = 1 , L
               P1(i,mp1) = P2(i,mp1)
               P2(i,mp1) = P3(i,mp1)
            ENDDO
         ENDDO
      ELSEIF ( N.LT.1 ) THEN
         DO i = 1 , L
            P3(i,1) = Phz(i,1)
         ENDDO
         RETURN
      ELSEIF ( N.EQ.1 ) THEN
         DO i = 1 , L
            P3(i,1) = Phz(i,2)
            P3(i,2) = Ph1(i,2)
         ENDDO
         RETURN
      ELSE
         sq5s6 = SQRT(5./6.)
         sq1s6 = SQRT(1./6.)
         DO i = 1 , L
            P3(i,1) = Phz(i,3)
            P3(i,2) = Ph1(i,3)
            P3(i,3) = sq5s6*Phz(i,1) - sq1s6*P3(i,1)
            P1(i,1) = Phz(i,2)
            P1(i,2) = Ph1(i,2)
            P2(i,1) = Phz(i,3)
            P2(i,2) = Ph1(i,3)
            P2(i,3) = P3(i,3)
         ENDDO
         RETURN
      ENDIF
    END SUBROUTINE LFIM1

    
    SUBROUTINE DLFIM1(Init,Theta,L,N,Nm,Id,P3,Phz,Ph1,P1,P2,Cp)
      IMPLICIT  NONE

      DOUBLE PRECISION cc , cn , Cp , dd , ee , fm , fn , fnmm , fnpm , P1 , P2 ,   &
         & P3 , Ph1 , Phz , sq1s6 , sq5s6 , ssqrt2 , temp , Theta , tn
      INTEGER i , Id , Init , L , m , mp1 , N , nh , Nm , nm1 , nmp1 ,  &
            & np1

      DIMENSION P1(L,1) , P2(L,1) , P3(Id,1) , Phz(L,1) , Ph1(L,1) ,    &
              & Cp(1) , Theta(1)
      nmp1 = Nm + 1
      IF ( Init.EQ.0 ) THEN
         ssqrt2 = 1./SQRT(2.)
         DO i = 1 , L
            Phz(i,1) = ssqrt2
         ENDDO
         DO np1 = 2 , nmp1
            nh = np1 - 1
            CALL DALFK(nh,0,Cp)
            DO i = 1 , L
               CALL DLFPT(nh,0,Theta(i),Cp,Phz(i,np1))
            ENDDO
            CALL DALFK(nh,1,Cp)
            DO i = 1 , L
               CALL DLFPT(nh,1,Theta(i),Cp,Ph1(i,np1))
            ENDDO
         ENDDO
         RETURN
      ELSEIF ( N.GT.2 ) THEN
         nm1 = N - 1
         np1 = N + 1
         fn = FLOAT(N)
         tn = fn + fn
         cn = (tn+1.)/(tn-3.)
         DO i = 1 , L
            P3(i,1) = Phz(i,np1)
            P3(i,2) = Ph1(i,np1)
         ENDDO
         IF ( nm1.GE.3 ) THEN
            DO mp1 = 3 , nm1
               m = mp1 - 1
               fm = FLOAT(m)
               fnpm = fn + fm
               fnmm = fn - fm
               temp = fnpm*(fnpm-1.)
               cc = SQRT(cn*(fnpm-3.)*(fnpm-2.)/temp)
               dd = SQRT(cn*fnmm*(fnmm-1.)/temp)
               ee = SQRT((fnmm+1.)*(fnmm+2.)/temp)
               DO i = 1 , L
                  P3(i,mp1) = cc*P1(i,mp1-2) + dd*P1(i,mp1)             &
                            & - ee*P3(i,mp1-2)
               ENDDO
            ENDDO
         ENDIF
         fnpm = fn + fn - 1.
         temp = fnpm*(fnpm-1.)
         cc = SQRT(cn*(fnpm-3.)*(fnpm-2.)/temp)
         ee = SQRT(6./temp)
         DO i = 1 , L
            P3(i,N) = cc*P1(i,N-2) - ee*P3(i,N-2)
         ENDDO
         fnpm = fn + fn
         temp = fnpm*(fnpm-1.)
         cc = SQRT(cn*(fnpm-3.)*(fnpm-2.)/temp)
         ee = SQRT(2./temp)
         DO i = 1 , L
            P3(i,N+1) = cc*P1(i,N-1) - ee*P3(i,N-1)
         ENDDO
         DO mp1 = 1 , np1
            DO i = 1 , L
               P1(i,mp1) = P2(i,mp1)
               P2(i,mp1) = P3(i,mp1)
            ENDDO
         ENDDO
      ELSEIF ( N.LT.1 ) THEN
         DO i = 1 , L
            P3(i,1) = Phz(i,1)
         ENDDO
         RETURN
      ELSEIF ( N.EQ.1 ) THEN
         DO i = 1 , L
            P3(i,1) = Phz(i,2)
            P3(i,2) = Ph1(i,2)
         ENDDO
         RETURN
      ELSE
         sq5s6 = SQRT(5./6.)
         sq1s6 = SQRT(1./6.)
         DO i = 1 , L
            P3(i,1) = Phz(i,3)
            P3(i,2) = Ph1(i,3)
            P3(i,3) = sq5s6*Phz(i,1) - sq1s6*P3(i,1)
            P1(i,1) = Phz(i,2)
            P1(i,2) = Ph1(i,2)
            P2(i,1) = Phz(i,3)
            P2(i,2) = Ph1(i,3)
            P2(i,3) = P3(i,3)
         ENDDO
         RETURN
      ENDIF
    END SUBROUTINE DLFIM1

! subroutine lfin (init,theta,l,m,nm,pb,id,wlfin)
!
! dimension of           theta(l),  pb(id,nm+1),  wlfin(4*l*(nm+1))
! arguments
!
! purpose                given m and l, routine lfin calculates
!                        the normalized associated legendre functions
!                        pbar(n,m,theta) for n=m,...,nm and theta(i)
!                        for i=1,...,l where
!
!                        pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
!                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
!                        factorial(n)) times the (n+m)th derivative of
!                        (x**2-1)**n with respect to x=cos(theta)
!
! usage                  call lfin (init,theta,l,m,nm,pb,id,wlfin)
!
! arguments
! on input               init
!                        = 0
!                            initialization only - using parameters
!                            l, nm and the array theta, subroutine lfin
!                            initializes the array wlfin for subsequent
!                            use in the computation of the associated
!                            legendre functions pb. initialization does
!                            not have to be repeated unless l, nm or
!                            the array theta are changed.
!                        = 1
!                            subroutine lfin uses the array wlfin that
!                            was computed with init = 0 to compute pb
!
!                        theta
!                          an array that contains the colatitudes
!                          at which the associated legendre functions
!                          will be computed. the colatitudes must be
!                          specified in radians.
!
!                        l
!                          the length of the theta array. lfin is
!                          vectorized with vector length l.
!
!                        m
!                          nonnegative integer, less than nm, specifying
!                          degree of pbar(n,m,theta). subroutine lfin
!                          must be called starting with n=0. n must be
!                          incremented by one in subsequent calls and
!                          must not exceed nm.
!
!                        nm
!                          the maximum value of n and m
!
!                        id
!                          the first dimension of the two dimensional
!                          array pb as it appears in the program that
!                          calls lfin. (see output parameter pb)
!
!                        wlfin
!                          an array with length 4*l*(nm+1) which
!                          must be initialized by calling lfin
!                          with init=0 (see parameter init)  it
!                          must not be altered between calls to
!                          lfin.
!
!
! on output              pb
!                          a two dimensional array with first
!                          dimension id in the program that calls
!                          lfin. the second dimension of pb must
!                          be at least nm+1. starting with m=0
!                          lfin is called repeatedly with m being
!                          increased by one between calls. on each
!                          call, subroutine lfin computes pb(i,n+1)
!                          = pbar(m,n,theta(i)) for n=m,...,nm and
!                          i=1,...l.
!
!                        wlfin
!                          array containing values which must not
!                          be altered unless l, nm or the array theta
!                          are changed in which case lfin must be
!                          called with init=0 to reinitialize the
!                          wlfin array.
!
! special conditions     m must be increased by one between calls
!                        of lfin in which m is not zero.
!
! precision              single
!
! algorithm              routine lfin calculates pbar(n,m,theta) using
!                        a four term recurrence relation. (unpublished
!                        notes by paul n. swarztrauber)
!
      SUBROUTINE LFIN(Init,Theta,L,M,Nm,Pb,Id,Wlfin)
      IMPLICIT NONE

      INTEGER Id , Init , iw1 , iw2 , iw3 , L , lnx , M , Nm
      REAL Theta

      REAL, DIMENSION(1) :: Pb, Wlfin

!     total length of wlfin is 4*l*(nm+1)

      lnx = L*(Nm+1)
      iw1 = lnx + 1
      iw2 = iw1 + lnx
      iw3 = iw2 + lnx
      CALL LFIN1(Init,Theta,L,M,Nm,Id,Pb,Wlfin,Wlfin(iw1),Wlfin(iw2),   &
               & Wlfin(iw3),Wlfin(iw2))
    END SUBROUTINE LFIN

    
    SUBROUTINE DLFIN(Init,Theta,L,M,Nm,Pb,Id,Wlfin)
      IMPLICIT NONE

      INTEGER Id , Init , iw1 , iw2 , iw3 , L , lnx , M , Nm
      DOUBLE PRECISION, DIMENSION(1) :: Pb ,  Wlfin
      DOUBLE PRECISION :: Theta

      !     total length of wlfin is 4*l*(nm+1)

      lnx = L*(Nm+1)
      iw1 = lnx + 1
      iw2 = iw1 + lnx
      iw3 = iw2 + lnx
      CALL DLFIN1(Init,Theta,L,M,Nm,Id,Pb,Wlfin,Wlfin(iw1),Wlfin(iw2),   &
               & Wlfin(iw3),Wlfin(iw2))
      END SUBROUTINE DLFIN

      
      SUBROUTINE LFIN1(Init,Theta,L,M,Nm,Id,P3,Phz,Ph1,P1,P2,Cp)
      IMPLICIT NONE

      REAL cc , cn , Cp , dd , ee , fm , fn , fnmm , fnpm , P1 , P2 ,   &
         & P3 , Ph1 , Phz , ssqrt2 , temp , Theta , tm , tn
      INTEGER i , Id , Init , L , M , mp1 , mp3 , n , nh , Nm , nmp1 ,  &
            & np1

      DIMENSION P1(L,1) , P2(L,1) , P3(Id,1) , Phz(L,1) , Ph1(L,1) ,    &
              & Cp(1) , Theta(1)
      nmp1 = Nm + 1
      IF ( Init.NE.0 ) THEN
         mp1 = M + 1
         fm = FLOAT(M)
         tm = fm + fm
         IF ( M.LT.1 ) THEN
            DO np1 = 1 , nmp1
               DO i = 1 , L
                  P3(i,np1) = Phz(i,np1)
                  P1(i,np1) = Phz(i,np1)
               ENDDO
            ENDDO
            RETURN
         ELSEIF ( M.EQ.1 ) THEN
            DO np1 = 2 , nmp1
               DO i = 1 , L
                  P3(i,np1) = Ph1(i,np1)
                  P2(i,np1) = Ph1(i,np1)
               ENDDO
            ENDDO
            RETURN
         ELSE
            temp = tm*(tm-1.)
            cc = SQRT((tm+1.)*(tm-2.)/temp)
            ee = SQRT(2./temp)
            DO i = 1 , L
               P3(i,M+1) = cc*P1(i,M-1) - ee*P1(i,M+1)
            ENDDO
            IF ( M.EQ.Nm ) RETURN
            temp = tm*(tm+1.)
            cc = SQRT((tm+3.)*(tm-2.)/temp)
            ee = SQRT(6./temp)
            DO i = 1 , L
               P3(i,M+2) = cc*P1(i,M) - ee*P1(i,M+2)
            ENDDO
            mp3 = M + 3
            IF ( nmp1.GE.mp3 ) THEN
               DO np1 = mp3 , nmp1
                  n = np1 - 1
                  fn = FLOAT(n)
                  tn = fn + fn
                  cn = (tn+1.)/(tn-3.)
                  fnpm = fn + fm
                  fnmm = fn - fm
                  temp = fnpm*(fnpm-1.)
                  cc = SQRT(cn*(fnpm-3.)*(fnpm-2.)/temp)
                  dd = SQRT(cn*fnmm*(fnmm-1.)/temp)
                  ee = SQRT((fnmm+1.)*(fnmm+2.)/temp)
                  DO i = 1 , L
                     P3(i,np1) = cc*P1(i,np1-2) + dd*P3(i,np1-2)        &
                               & - ee*P1(i,np1)
                  ENDDO
               ENDDO
            ENDIF
            DO np1 = M , nmp1
               DO i = 1 , L
                  P1(i,np1) = P2(i,np1)
                  P2(i,np1) = P3(i,np1)
               ENDDO
            ENDDO
         ENDIF
      ELSE
         ssqrt2 = 1./SQRT(2.)
         DO i = 1 , L
            Phz(i,1) = ssqrt2
         ENDDO
         DO np1 = 2 , nmp1
            nh = np1 - 1
            CALL ALFK(nh,0,Cp)
            DO i = 1 , L
               CALL LFPT(nh,0,Theta(i),Cp,Phz(i,np1))
            ENDDO
            CALL ALFK(nh,1,Cp)
            DO i = 1 , L
               CALL LFPT(nh,1,Theta(i),Cp,Ph1(i,np1))
            ENDDO
         ENDDO
         RETURN
      ENDIF
    END SUBROUTINE LFIN1

    
    SUBROUTINE DLFIN1(Init,Theta,L,M,Nm,Id,P3,Phz,Ph1,P1,P2,Cp)
      IMPLICIT NONE


      DOUBLE PRECISION cc , cn , Cp , dd , ee , fm , fn , fnmm , fnpm , P1 , P2 ,   &
         & P3 , Ph1 , Phz , ssqrt2 , temp , Theta , tm , tn
      INTEGER i , Id , Init , L , M , mp1 , mp3 , n , nh , Nm , nmp1 ,  &
            & np1

      DIMENSION P1(L,1) , P2(L,1) , P3(Id,1) , Phz(L,1) , Ph1(L,1) ,    &
              & Cp(1) , Theta(1)
      nmp1 = Nm + 1
      IF ( Init.NE.0 ) THEN
         mp1 = M + 1
         fm = FLOAT(M)
         tm = fm + fm
         IF ( M.LT.1 ) THEN
            DO np1 = 1 , nmp1
               DO i = 1 , L
                  P3(i,np1) = Phz(i,np1)
                  P1(i,np1) = Phz(i,np1)
               ENDDO
            ENDDO
            RETURN
         ELSEIF ( M.EQ.1 ) THEN
            DO np1 = 2 , nmp1
               DO i = 1 , L
                  P3(i,np1) = Ph1(i,np1)
                  P2(i,np1) = Ph1(i,np1)
               ENDDO
            ENDDO
            RETURN
         ELSE
            temp = tm*(tm-1.)
            cc = SQRT((tm+1.)*(tm-2.)/temp)
            ee = SQRT(2./temp)
            DO i = 1 , L
               P3(i,M+1) = cc*P1(i,M-1) - ee*P1(i,M+1)
            ENDDO
            IF ( M.EQ.Nm ) RETURN
            temp = tm*(tm+1.)
            cc = SQRT((tm+3.)*(tm-2.)/temp)
            ee = SQRT(6./temp)
            DO i = 1 , L
               P3(i,M+2) = cc*P1(i,M) - ee*P1(i,M+2)
            ENDDO
            mp3 = M + 3
            IF ( nmp1.GE.mp3 ) THEN
               DO np1 = mp3 , nmp1
                  n = np1 - 1
                  fn = FLOAT(n)
                  tn = fn + fn
                  cn = (tn+1.)/(tn-3.)
                  fnpm = fn + fm
                  fnmm = fn - fm
                  temp = fnpm*(fnpm-1.)
                  cc = SQRT(cn*(fnpm-3.)*(fnpm-2.)/temp)
                  dd = SQRT(cn*fnmm*(fnmm-1.)/temp)
                  ee = SQRT((fnmm+1.)*(fnmm+2.)/temp)
                  DO i = 1 , L
                     P3(i,np1) = cc*P1(i,np1-2) + dd*P3(i,np1-2)        &
                               & - ee*P1(i,np1)
                  ENDDO
               ENDDO
            ENDIF
            DO np1 = M , nmp1
               DO i = 1 , L
                  P1(i,np1) = P2(i,np1)
                  P2(i,np1) = P3(i,np1)
               ENDDO
            ENDDO
         ENDIF
      ELSE
         ssqrt2 = 1./SQRT(2.)
         DO i = 1 , L
            Phz(i,1) = ssqrt2
         ENDDO
         DO np1 = 2 , nmp1
            nh = np1 - 1
            CALL DALFK(nh,0,Cp)
            DO i = 1 , L
               CALL DLFPT(nh,0,Theta(i),Cp,Phz(i,np1))
            ENDDO
            CALL DALFK(nh,1,Cp)
            DO i = 1 , L
               CALL DLFPT(nh,1,Theta(i),Cp,Ph1(i,np1))
            ENDDO
         ENDDO
         RETURN
      ENDIF
      END SUBROUTINE DLFIN1

! subroutine lfpt (n,m,theta,cp,pb)
!
! dimension of
! arguments
!                        cp((n/2)+1)
!
! purpose                routine lfpt uses coefficients computed by
!                        routine alfk to compute the single precision
!                        normalized associated legendre function pbar(n,
!                        m,theta) at colatitude theta.
!
! usage                  call lfpt(n,m,theta,cp,pb)
!
! arguments
!
! on input               n
!                          nonnegative integer specifying the degree of
!                          pbar(n,m,theta)
!                        m
!                          is the order of pbar(n,m,theta). m can be
!                          any integer however pbar(n,m,theta) = 0
!                          if abs(m) is greater than n and
!                          pbar(n,m,theta) = (-1)**m*pbar(n,-m,theta)
!                          for negative m.
!
!                        theta
!                          single precision colatitude in radians
!
!                        cp
!                          single precision array of length (n/2)+1
!                          containing coefficients computed by routine
!                          alfk
!
! on output              pb
!                          single precision variable containing
!                          pbar(n,m,theta)
!
! special conditions     calls to routine lfpt must be preceded by an
!                        appropriate call to routine alfk.
!
! precision              single
!
! algorithm              the trigonometric series formula used by
!                        routine lfpt to calculate pbar(n,m,th) at
!                        colatitude th depends on m and n as follows:
!
!                           1) for n even and m even, the formula is
!                              .5*cp(1) plus the sum from k=1 to k=n/2
!                              of cp(k)*cos(2*k*th)
!                           2) for n even and m odd. the formula is
!                              the sum from k=1 to k=n/2 of
!                              cp(k)*sin(2*k*th)
!                           3) for n odd and m even, the formula is
!                              the sum from k=1 to k=(n+1)/2 of
!                              cp(k)*cos((2*k-1)*th)
!                           4) for n odd and m odd, the formula is
!                              the sum from k=1 to k=(n+1)/2 of
!                              cp(k)*sin((2*k-1)*th)
!
! accuracy               comparison between routines lfpt and double
!                        precision dlfpt on the cray1 indicates greater
!                        accuracy for greater values on input parameter
!                        n.  agreement to 13 places was obtained for
!                        n=10 and to 12 places for n=100.
!
! timing                 time per call to routine lfpt is dependent on
!                        the input parameter n.
!
      SUBROUTINE LFPT(N,M,Theta,Cp,Pb)
      IMPLICIT NONE

      REAL cdt , ct , cth , Pb , sdt , st , sum , Theta
      INTEGER k , kdo , kp1 , M , ma , mmod , N , nmod , np1

      REAL, DIMENSION(1) ::  Cp
!
      Pb = 0.
      ma = IABS(M)
      IF ( ma.GT.N ) RETURN
      IF ( N.LE.0 ) THEN
         IF ( ma.LE.0 ) THEN
            Pb = SQRT(.5)
            GOTO 99999
         ENDIF
      ENDIF
      np1 = N + 1
      nmod = MOD(N,2)
      mmod = MOD(ma,2)
      IF ( nmod.GT.0 ) THEN
         kdo = (N+1)/2
         IF ( mmod.LE.0 ) THEN
            cdt = COS(Theta+Theta)
            sdt = SIN(Theta+Theta)
            ct = COS(Theta)
            st = -SIN(Theta)
            sum = 0.
            DO k = 1 , kdo
               cth = cdt*ct - sdt*st
               st = sdt*ct + cdt*st
               ct = cth
               sum = sum + Cp(k)*ct
            ENDDO
            Pb = sum
         ELSE
            cdt = COS(Theta+Theta)
            sdt = SIN(Theta+Theta)
            ct = COS(Theta)
            st = -SIN(Theta)
            sum = 0.
            DO k = 1 , kdo
               cth = cdt*ct - sdt*st
               st = sdt*ct + cdt*st
               ct = cth
               sum = sum + Cp(k)*st
            ENDDO
            Pb = sum
         ENDIF
      ELSEIF ( mmod.LE.0 ) THEN
         kdo = N/2 + 1
         cdt = COS(Theta+Theta)
         sdt = SIN(Theta+Theta)
         ct = 1.
         st = 0.
         sum = .5*Cp(1)
         DO kp1 = 2 , kdo
            cth = cdt*ct - sdt*st
            st = sdt*ct + cdt*st
            ct = cth
            sum = sum + Cp(kp1)*ct
         ENDDO
         Pb = sum
      ELSE
         kdo = N/2
         cdt = COS(Theta+Theta)
         sdt = SIN(Theta+Theta)
         ct = 1.
         st = 0.
         sum = 0.
         DO k = 1 , kdo
            cth = cdt*ct - sdt*st
            st = sdt*ct + cdt*st
            ct = cth
            sum = sum + Cp(k)*st
         ENDDO
         Pb = sum
      ENDIF
99999 END SUBROUTINE LFPT

      
      SUBROUTINE DLFPT(N,M,Theta,Cp,Pb)
      IMPLICIT NONE

      DOUBLE PRECISION cdt , ct , cth , Pb , sdt , st , sum , Theta
      INTEGER k , kdo , kp1 , M , ma , mmod , N , nmod , np1

      DOUBLE PRECISION, DIMENSION(1) ::  Cp
!
      Pb = 0.
      ma = IABS(M)
      IF ( ma.GT.N ) RETURN
      IF ( N.LE.0 ) THEN
         IF ( ma.LE.0 ) THEN
            Pb = SQRT(.5)
            GOTO 99999
         ENDIF
      ENDIF
      np1 = N + 1
      nmod = MOD(N,2)
      mmod = MOD(ma,2)
      IF ( nmod.GT.0 ) THEN
         kdo = (N+1)/2
         IF ( mmod.LE.0 ) THEN
            cdt = COS(Theta+Theta)
            sdt = SIN(Theta+Theta)
            ct = COS(Theta)
            st = -SIN(Theta)
            sum = 0.
            DO k = 1 , kdo
               cth = cdt*ct - sdt*st
               st = sdt*ct + cdt*st
               ct = cth
               sum = sum + Cp(k)*ct
            ENDDO
            Pb = sum
         ELSE
            cdt = COS(Theta+Theta)
            sdt = SIN(Theta+Theta)
            ct = COS(Theta)
            st = -SIN(Theta)
            sum = 0.
            DO k = 1 , kdo
               cth = cdt*ct - sdt*st
               st = sdt*ct + cdt*st
               ct = cth
               sum = sum + Cp(k)*st
            ENDDO
            Pb = sum
         ENDIF
      ELSEIF ( mmod.LE.0 ) THEN
         kdo = N/2 + 1
         cdt = COS(Theta+Theta)
         sdt = SIN(Theta+Theta)
         ct = 1.
         st = 0.
         sum = .5*Cp(1)
         DO kp1 = 2 , kdo
            cth = cdt*ct - sdt*st
            st = sdt*ct + cdt*st
            ct = cth
            sum = sum + Cp(kp1)*ct
         ENDDO
         Pb = sum
      ELSE
         kdo = N/2
         cdt = COS(Theta+Theta)
         sdt = SIN(Theta+Theta)
         ct = 1.
         st = 0.
         sum = 0.
         DO k = 1 , kdo
            cth = cdt*ct - sdt*st
            st = sdt*ct + cdt*st
            ct = cth
            sum = sum + Cp(k)*st
         ENDDO
         Pb = sum
      ENDIF
99999 END SUBROUTINE DLFPT
