
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         SPHEREPACK3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
!
! ... file shses.f
!
!     this file contains code and documentation for subroutines
!     shses and shsesi
!
! ... files which must be loaded with shses.f
!
!     sphcom.f, hrfft.f
!
!     subroutine shses(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
!    +                 wshses,lshses,work,lwork,ierror)
!
!     subroutine shses performs the spherical harmonic synthesis
!     on the arrays a and b and stores the result in the array g.
!     the synthesis is performed on an equally spaced grid.  the
!     associated legendre functions are stored rather than recomputed
!     as they are in subroutine shsec.  the synthesis is described
!     below at output parameter g.
!
! *** required files from spherepack2
!
!     sphcom.f, hrfft.f
!
!
!     input parameters
!
!     nlat   the number of colatitudes on the full sphere including the
!            poles. for example, nlat = 37 for a five degree grid.
!            nlat determines the grid increment in colatitude as
!            pi/(nlat-1).  if nlat is odd the equator is located at
!            grid point i=(nlat+1)/2. if nlat is even the equator is
!            located half way between points i=nlat/2 and i=nlat/2+1.
!            nlat must be at least 3. note: on the half sphere, the
!            number of grid points in the colatitudinal direction is
!            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
!
!     nlon   the number of distinct londitude points.  nlon determines
!            the grid increment in longitude as 2*pi/nlon. for example
!            nlon = 72 for a five degree grid. nlon must be greater
!            than or equal to 4. the efficiency of the computation is
!            improved when nlon is a product of small prime numbers.
!
!     isym   = 0  no symmetries exist about the equator. the synthesis
!                 is performed on the entire sphere.  i.e. on the
!                 array g(i,j) for i=1,...,nlat and j=1,...,nlon.
!                 (see description of g below)
!
!            = 1  g is antisymmetric about the equator. the synthesis
!                 is performed on the northern hemisphere only.  i.e.
!                 if nlat is odd the synthesis is performed on the
!                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
!                 if nlat is even the synthesis is performed on the
!                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
!
!
!            = 2  g is symmetric about the equator. the synthesis is
!                 performed on the northern hemisphere only.  i.e.
!                 if nlat is odd the synthesis is performed on the
!                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
!                 if nlat is even the synthesis is performed on the
!                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
!
!     nt     the number of syntheses.  in the program that calls shses,
!            the arrays g,a and b can be three dimensional in which
!            case multiple syntheses will be performed.  the third
!            index is the synthesis index which assumes the values
!            k=1,...,nt.  for a single synthesis set nt=1. the
!            discription of the remaining parameters is simplified
!            by assuming that nt=1 or that the arrays g,a and b
!            have only two dimensions.
!
!     idg    the first dimension of the array g as it appears in the
!            program that calls shses.  if isym equals zero then idg
!            must be at least nlat.  if isym is nonzero then idg
!            must be at least nlat/2 if nlat is even or at least
!            (nlat+1)/2 if nlat is odd.
!
!     jdg    the second dimension of the array g as it appears in the
!            program that calls shses.  jdg must be at least nlon.
!
!     a,b    two or three dimensional arrays (see the input parameter
!            nt) that contain the coefficients in the spherical harmonic
!            expansion of g(i,j) given below at the definition of the
!            output parameter g.  a(m,n) and b(m,n) are defined for
!            indices m=1,...,mmax and n=m,...,nlat where mmax is the
!            maximum (plus one) longitudinal wave number given by
!            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
!            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
!
!     mdab   the first dimension of the arrays a and b as it appears
!            in the program that calls shses. mdab must be at least
!            min0(nlat,(nlon+2)/2) if nlon is even or at least
!            min0(nlat,(nlon+1)/2) if nlon is odd.
!
!     ndab   the second dimension of the arrays a and b as it appears
!            in the program that calls shses. ndab must be at least nlat
!
!     wshses an array which must be initialized by subroutine shsesi.
!            once initialized, wshses can be used repeatedly by shses
!            as long as nlon and nlat remain unchanged.  wshses must
!            not be altered between calls of shses.
!
!     lshses the dimension of the array wshses as it appears in the
!            program that calls shses. define
!
!               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
!               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
!
!            and
!
!               l2 = nlat/2        if nlat is even or
!               l2 = (nlat+1)/2    if nlat is odd
!
!            then lshses must be at least
!
!               (l1*l2*(nlat+nlat-l1+1))/2+nlon+15
!
!     work   a work array that does not have to be saved.
!
!     lwork  the dimension of the array work as it appears in the
!            program that calls shses.  define
!
!               l2 = nlat/2        if nlat is even or
!               l2 = (nlat+1)/2    if nlat is odd
!
!            if isym is zero then lwork must be at least
!
!               (nt+1)*nlat*nlon
!
!            if isym is nonzero lwork must be at least
!
!               (nt+1)*l2*nlon.
!
!     **************************************************************
!
!     output parameters
!
!     g      a two or three dimensional array (see input parameter
!            nt) that contains the spherical harmonic synthesis of
!            the arrays a and b at the colatitude point theta(i) =
!            (i-1)*pi/(nlat-1) and longitude point phi(j) =
!            (j-1)*2*pi/nlon. the index ranges are defined above at
!            at the input parameter isym.  for isym=0, g(i,j) is
!            given by the the equations listed below.  symmetric
!            versions are used when isym is greater than zero.
!
!     the normalized associated legendre functions are given by
!
!     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)
!
!     define the maximum (plus one) longitudinal wave number
!     as   mmax = min0(nlat,(nlon+2)/2) if nlon is even or
!          mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
!
!     then g(i,j) = the sum from n=0 to n=nlat-1 of
!
!                   .5*pbar(0,n,theta(i))*a(1,n+1)
!
!              plus the sum from m=1 to m=mmax-1 of
!
!                   the sum from n=m to n=nlat-1 of
!
!              pbar(m,n,theta(i))*(a(m+1,n+1)*cos(m*phi(j))
!                                    -b(m+1,n+1)*sin(m*phi(j)))
!
!
!     ierror = 0  no errors
!            = 1  error in the specification of nlat
!            = 2  error in the specification of nlon
!            = 3  error in the specification of isym
!            = 4  error in the specification of nt
!            = 5  error in the specification of idg
!            = 6  error in the specification of jdg
!            = 7  error in the specification of mdab
!            = 8  error in the specification of ndab
!            = 9  error in the specification of lshses
!            = 10 error in the specification of lwork
!
!
! ****************************************************************
!     subroutine shsesi(nlat,nlon,wshses,lshses,work,lwork,dwork,
!    +                  ldwork,ierror)
!
!     subroutine shsesi initializes the array wshses which can then
!     be used repeatedly by subroutine shses.
!
!     input parameters
!
!     nlat   the number of colatitudes on the full sphere including the
!            poles. for example, nlat = 37 for a five degree grid.
!            nlat determines the grid increment in colatitude as
!            pi/(nlat-1).  if nlat is odd the equator is located at
!            grid point i=(nlat+1)/2. if nlat is even the equator is
!            located half way between points i=nlat/2 and i=nlat/2+1.
!            nlat must be at least 3. note: on the half sphere, the
!            number of grid points in the colatitudinal direction is
!            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
!
!     nlon   the number of distinct londitude points.  nlon determines
!            the grid increment in longitude as 2*pi/nlon. for example
!            nlon = 72 for a five degree grid. nlon must be greater
!            than or equal to 4. the efficiency of the computation is
!            improved when nlon is a product of small prime numbers.
!
!     lshses the dimension of the array wshses as it appears in the
!            program that calls shsesi. define
!
!               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
!               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
!
!            and
!
!               l2 = nlat/2        if nlat is even or
!               l2 = (nlat+1)/2    if nlat is odd
!
!            then lshses must be at least
!
!               (l1*l2*(nlat+nlat-l1+1))/2+nlon+15
!
!     work   a real   work array that does not have to be saved.
!
!     lwork  the dimension of the array work as it appears in
!            the program that calls shsesi.  define
!
!               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
!               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
!
!            and
!
!               l2 = nlat/2        if nlat is even or
!               l2 = (nlat+1)/2    if nlat is odd
!
!            then lwork must be at least
!
!               5*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2
!
!
!     dwork  a double precision work array that does not have to be saved.
!
!     ldwork the dimension of the array dwork as it appears in the
!            program that calls shsesi.  ldwork must be at least nlat+1
!
!
!     output parameters
!
!     wshses an array which is initialized for use by subroutine shses.
!            once initialized, wshses can be used repeatedly by shses
!            as long as nlon and nlat remain unchanged.  wshses must
!            not be altered between calls of shses.
!
!     ierror = 0  no errors
!            = 1  error in the specification of nlat
!            = 2  error in the specification of nlon
!            = 3  error in the specification of lshses
!            = 4  error in the specification of lwork
!            = 5  error in the specification of ldwork
!
! ****************************************************************
      SUBROUTINE SHSES(Nlat,Nlon,Isym,Nt,G,Idg,Jdg,A,B,Mdab,Ndab,Wshses,&
                     & Lshses,Work,Lwork,Ierror)
      IMPLICIT NONE
      REAL A , B , G , Work , Wshses
      INTEGER Idg , Ierror , imid , ist , Isym , Jdg , lpimn , ls ,     &
            & Lshses , Lwork , Mdab , mmax , Ndab , Nlat , nln , Nlon , &
            & Nt
      DIMENSION G(Idg,Jdg,1) , A(Mdab,Ndab,1) , B(Mdab,Ndab,1) ,        &
              & Wshses(1) , Work(1)
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<4 ) RETURN
      Ierror = 3
      IF ( Isym<0 .OR. Isym>2 ) RETURN
      Ierror = 4
      IF ( Nt<0 ) RETURN
      Ierror = 5
      IF ( (Isym==0 .AND. Idg<Nlat) .OR. (Isym/=0 .AND. Idg<(Nlat+1)/2) &
         & ) RETURN
      Ierror = 6
      IF ( Jdg<Nlon ) RETURN
      Ierror = 7
      mmax = MIN0(Nlat,Nlon/2+1)
      IF ( Mdab<mmax ) RETURN
      Ierror = 8
      IF ( Ndab<Nlat ) RETURN
      Ierror = 9
      imid = (Nlat+1)/2
      lpimn = (imid*mmax*(Nlat+Nlat-mmax+1))/2
      IF ( Lshses<lpimn+Nlon+15 ) RETURN
      Ierror = 10
      ls = Nlat
      IF ( Isym>0 ) ls = imid
      nln = Nt*ls*Nlon
      IF ( Lwork<nln+ls*Nlon ) RETURN
      Ierror = 0
      ist = 0
      IF ( Isym==0 ) ist = imid
      CALL SHSES1(Nlat,Isym,Nt,G,Idg,Jdg,A,B,Mdab,Ndab,Wshses,imid,ls,  &
                & Nlon,Work,Work(ist+1),Work(nln+1),Wshses(lpimn+1))
    END SUBROUTINE SHSES

    
      SUBROUTINE SHSES1(Nlat,Isym,Nt,G,Idgs,Jdgs,A,B,Mdab,Ndab,P,Imid,  &
                      & Idg,Jdg,Ge,Go,Work,Whrfft)
      IMPLICIT NONE
      REAL A , B , G , Ge , Go , P , Whrfft , Work
      INTEGER i , Idg , Idgs , Imid , imm1 , Isym , j , Jdg , Jdgs , k ,&
            & ls , m , mb , Mdab , mdo , mmax , mn , modl , mp1 , mp2
      INTEGER Ndab , ndo , Nlat , nlon , nlp1 , np1 , Nt
      DIMENSION G(Idgs,Jdgs,1) , A(Mdab,Ndab,1) , B(Mdab,Ndab,1) ,      &
              & P(Imid,1) , Ge(Idg,Jdg,1) , Go(Idg,Jdg,1) , Work(1) ,   &
              & Whrfft(1)
      ls = Idg
      nlon = Jdg
      mmax = MIN0(Nlat,nlon/2+1)
      mdo = mmax
      IF ( mdo+mdo-1>nlon ) mdo = mmax - 1
      nlp1 = Nlat + 1
      modl = MOD(Nlat,2)
      imm1 = Imid
      IF ( modl/=0 ) imm1 = Imid - 1
      DO k = 1 , Nt
         DO j = 1 , nlon
            DO i = 1 , ls
               Ge(i,j,k) = 0.
            ENDDO
         ENDDO
      ENDDO
      IF ( Isym/=1 ) THEN
         DO k = 1 , Nt
            DO np1 = 1 , Nlat , 2
               DO i = 1 , Imid
                  Ge(i,1,k) = Ge(i,1,k) + A(1,np1,k)*P(i,np1)
               ENDDO
            ENDDO
         ENDDO
         ndo = Nlat
         IF ( MOD(Nlat,2)==0 ) ndo = Nlat - 1
         DO mp1 = 2 , mdo
            m = mp1 - 1
            mb = m*(Nlat-1) - (m*(m-1))/2
            DO np1 = mp1 , ndo , 2
               mn = mb + np1
               DO k = 1 , Nt
                  DO i = 1 , Imid
                     Ge(i,2*mp1-2,k) = Ge(i,2*mp1-2,k) + A(mp1,np1,k)   &
                                     & *P(i,mn)
                     Ge(i,2*mp1-1,k) = Ge(i,2*mp1-1,k) + B(mp1,np1,k)   &
                                     & *P(i,mn)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
         IF ( mdo/=mmax .AND. mmax<=ndo ) THEN
            mb = mdo*(Nlat-1) - (mdo*(mdo-1))/2
            DO np1 = mmax , ndo , 2
               mn = mb + np1
               DO k = 1 , Nt
                  DO i = 1 , Imid
                     Ge(i,2*mmax-2,k) = Ge(i,2*mmax-2,k) + A(mmax,np1,k)&
                                      & *P(i,mn)
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
         IF ( Isym==2 ) GOTO 100
      ENDIF
      DO k = 1 , Nt
         DO np1 = 2 , Nlat , 2
            DO i = 1 , imm1
               Go(i,1,k) = Go(i,1,k) + A(1,np1,k)*P(i,np1)
            ENDDO
         ENDDO
      ENDDO
      ndo = Nlat
      IF ( MOD(Nlat,2)/=0 ) ndo = Nlat - 1
      DO mp1 = 2 , mdo
         mp2 = mp1 + 1
         m = mp1 - 1
         mb = m*(Nlat-1) - (m*(m-1))/2
         DO np1 = mp2 , ndo , 2
            mn = mb + np1
            DO k = 1 , Nt
               DO i = 1 , imm1
                  Go(i,2*mp1-2,k) = Go(i,2*mp1-2,k) + A(mp1,np1,k)      &
                                  & *P(i,mn)
                  Go(i,2*mp1-1,k) = Go(i,2*mp1-1,k) + B(mp1,np1,k)      &
                                  & *P(i,mn)
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      mp2 = mmax + 1
      IF ( mdo/=mmax .AND. mp2<=ndo ) THEN
         mb = mdo*(Nlat-1) - (mdo*(mdo-1))/2
         DO np1 = mp2 , ndo , 2
            mn = mb + np1
            DO k = 1 , Nt
               DO i = 1 , imm1
                  Go(i,2*mmax-2,k) = Go(i,2*mmax-2,k) + A(mmax,np1,k)   &
                                   & *P(i,mn)
               ENDDO
            ENDDO
         ENDDO
      ENDIF
 100  DO k = 1 , Nt
         IF ( MOD(nlon,2)==0 ) THEN
            DO i = 1 , ls
               Ge(i,nlon,k) = 2.*Ge(i,nlon,k)
            ENDDO
         ENDIF
         CALL HRFFTB(ls,nlon,Ge(1,1,k),ls,Whrfft,Work)
      ENDDO
      IF ( Isym/=0 ) THEN
         DO k = 1 , Nt
            DO i = 1 , Imid
               DO j = 1 , nlon
                  G(i,j,k) = .5*Ge(i,j,k)
               ENDDO
            ENDDO
         ENDDO
         GOTO 99999
      ENDIF
      DO k = 1 , Nt
         DO j = 1 , nlon
            DO i = 1 , imm1
               G(i,j,k) = .5*(Ge(i,j,k)+Go(i,j,k))
               G(nlp1-i,j,k) = .5*(Ge(i,j,k)-Go(i,j,k))
            ENDDO
            IF ( modl/=0 ) G(Imid,j,k) = .5*Ge(Imid,j,k)
         ENDDO
      ENDDO
      RETURN
99999 END SUBROUTINE SHSES1

      
      SUBROUTINE SHSESI(Nlat,Nlon,Wshses,Lshses,Work,Lwork,Dwork,Ldwork,&
                      & Ierror)
      IMPLICIT NONE
      INTEGER Ierror , imid , iw1 , labc , Ldwork , lpimn , Lshses ,    &
            & Lwork , mmax , Nlat , Nlon
      REAL Work , Wshses
      DIMENSION Wshses(*) , Work(*)
      DOUBLE PRECISION Dwork(*)
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<4 ) RETURN
      Ierror = 3
      mmax = MIN0(Nlat,Nlon/2+1)
      imid = (Nlat+1)/2
      lpimn = (imid*mmax*(Nlat+Nlat-mmax+1))/2
      IF ( Lshses<lpimn+Nlon+15 ) RETURN
      Ierror = 4
      labc = 3*((mmax-2)*(Nlat+Nlat-mmax-1))/2
      IF ( Lwork<5*Nlat*imid+labc ) RETURN
      Ierror = 5
      IF ( Ldwork<Nlat+1 ) RETURN
      Ierror = 0
      iw1 = 3*Nlat*imid + 1
      CALL SES1(Nlat,Nlon,imid,Wshses,Work,Work(iw1),Dwork)
      CALL HRFFTI(Nlon,Wshses(lpimn+1))
    END SUBROUTINE SHSESI


    
    SUBROUTINE DSHSES(Nlat,Nlon,Isym,Nt,G,Idg,Jdg,A,B,Mdab,Ndab,Wshses,&
                     & Lshses,Work,Lwork,Ierror)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , G , Work , Wshses
      INTEGER Idg , Ierror , imid , ist , Isym , Jdg , lpimn , ls ,     &
            & Lshses , Lwork , Mdab , mmax , Ndab , Nlat , nln , Nlon , &
            & Nt
      DIMENSION G(Idg,Jdg,1) , A(Mdab,Ndab,1) , B(Mdab,Ndab,1) ,        &
              & Wshses(1) , Work(1)
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<4 ) RETURN
      Ierror = 3
      IF ( Isym<0 .OR. Isym>2 ) RETURN
      Ierror = 4
      IF ( Nt<0 ) RETURN
      Ierror = 5
      IF ( (Isym==0 .AND. Idg<Nlat) .OR. (Isym/=0 .AND. Idg<(Nlat+1)/2) &
         & ) RETURN
      Ierror = 6
      IF ( Jdg<Nlon ) RETURN
      Ierror = 7
      mmax = MIN0(Nlat,Nlon/2+1)
      IF ( Mdab<mmax ) RETURN
      Ierror = 8
      IF ( Ndab<Nlat ) RETURN
      Ierror = 9
      imid = (Nlat+1)/2
      lpimn = (imid*mmax*(Nlat+Nlat-mmax+1))/2
      IF ( Lshses<lpimn+Nlon+15 ) RETURN
      Ierror = 10
      ls = Nlat
      IF ( Isym>0 ) ls = imid
      nln = Nt*ls*Nlon
      IF ( Lwork<nln+ls*Nlon ) RETURN
      Ierror = 0
      ist = 0
      IF ( Isym==0 ) ist = imid
      CALL DSHSES1(Nlat,Isym,Nt,G,Idg,Jdg,A,B,Mdab,Ndab,Wshses,imid,ls,  &
                & Nlon,Work,Work(ist+1),Work(nln+1),Wshses(lpimn+1))
    END SUBROUTINE DSHSES

    
      SUBROUTINE DSHSES1(Nlat,Isym,Nt,G,Idgs,Jdgs,A,B,Mdab,Ndab,P,Imid,  &
                      & Idg,Jdg,Ge,Go,Work,Whrfft)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , G , Ge , Go , P , Whrfft , Work
      INTEGER i , Idg , Idgs , Imid , imm1 , Isym , j , Jdg , Jdgs , k ,&
            & ls , m , mb , Mdab , mdo , mmax , mn , modl , mp1 , mp2
      INTEGER Ndab , ndo , Nlat , nlon , nlp1 , np1 , Nt
      DIMENSION G(Idgs,Jdgs,1) , A(Mdab,Ndab,1) , B(Mdab,Ndab,1) ,      &
              & P(Imid,1) , Ge(Idg,Jdg,1) , Go(Idg,Jdg,1) , Work(1) ,   &
              & Whrfft(1)
      ls = Idg
      nlon = Jdg
      mmax = MIN0(Nlat,nlon/2+1)
      mdo = mmax
      IF ( mdo+mdo-1>nlon ) mdo = mmax - 1
      nlp1 = Nlat + 1
      modl = MOD(Nlat,2)
      imm1 = Imid
      IF ( modl/=0 ) imm1 = Imid - 1
      DO k = 1 , Nt
         DO j = 1 , nlon
            DO i = 1 , ls
               Ge(i,j,k) = 0.
            ENDDO
         ENDDO
      ENDDO
      IF ( Isym/=1 ) THEN
         DO k = 1 , Nt
            DO np1 = 1 , Nlat , 2
               DO i = 1 , Imid
                  Ge(i,1,k) = Ge(i,1,k) + A(1,np1,k)*P(i,np1)
               ENDDO
            ENDDO
         ENDDO
         ndo = Nlat
         IF ( MOD(Nlat,2)==0 ) ndo = Nlat - 1
         DO mp1 = 2 , mdo
            m = mp1 - 1
            mb = m*(Nlat-1) - (m*(m-1))/2
            DO np1 = mp1 , ndo , 2
               mn = mb + np1
               DO k = 1 , Nt
                  DO i = 1 , Imid
                     Ge(i,2*mp1-2,k) = Ge(i,2*mp1-2,k) + A(mp1,np1,k)   &
                                     & *P(i,mn)
                     Ge(i,2*mp1-1,k) = Ge(i,2*mp1-1,k) + B(mp1,np1,k)   &
                                     & *P(i,mn)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
         IF ( mdo/=mmax .AND. mmax<=ndo ) THEN
            mb = mdo*(Nlat-1) - (mdo*(mdo-1))/2
            DO np1 = mmax , ndo , 2
               mn = mb + np1
               DO k = 1 , Nt
                  DO i = 1 , Imid
                     Ge(i,2*mmax-2,k) = Ge(i,2*mmax-2,k) + A(mmax,np1,k)&
                                      & *P(i,mn)
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
         IF ( Isym==2 ) GOTO 100
      ENDIF
      DO k = 1 , Nt
         DO np1 = 2 , Nlat , 2
            DO i = 1 , imm1
               Go(i,1,k) = Go(i,1,k) + A(1,np1,k)*P(i,np1)
            ENDDO
         ENDDO
      ENDDO
      ndo = Nlat
      IF ( MOD(Nlat,2)/=0 ) ndo = Nlat - 1
      DO mp1 = 2 , mdo
         mp2 = mp1 + 1
         m = mp1 - 1
         mb = m*(Nlat-1) - (m*(m-1))/2
         DO np1 = mp2 , ndo , 2
            mn = mb + np1
            DO k = 1 , Nt
               DO i = 1 , imm1
                  Go(i,2*mp1-2,k) = Go(i,2*mp1-2,k) + A(mp1,np1,k)      &
                                  & *P(i,mn)
                  Go(i,2*mp1-1,k) = Go(i,2*mp1-1,k) + B(mp1,np1,k)      &
                                  & *P(i,mn)
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      mp2 = mmax + 1
      IF ( mdo/=mmax .AND. mp2<=ndo ) THEN
         mb = mdo*(Nlat-1) - (mdo*(mdo-1))/2
         DO np1 = mp2 , ndo , 2
            mn = mb + np1
            DO k = 1 , Nt
               DO i = 1 , imm1
                  Go(i,2*mmax-2,k) = Go(i,2*mmax-2,k) + A(mmax,np1,k)   &
                                   & *P(i,mn)
               ENDDO
            ENDDO
         ENDDO
      ENDIF
 100  DO k = 1 , Nt
         IF ( MOD(nlon,2)==0 ) THEN
            DO i = 1 , ls
               Ge(i,nlon,k) = 2.*Ge(i,nlon,k)
            ENDDO
         ENDIF
         CALL DHRFFTB(ls,nlon,Ge(1,1,k),ls,Whrfft,Work)
      ENDDO
      IF ( Isym/=0 ) THEN
         DO k = 1 , Nt
            DO i = 1 , Imid
               DO j = 1 , nlon
                  G(i,j,k) = .5*Ge(i,j,k)
               ENDDO
            ENDDO
         ENDDO
         GOTO 99999
      ENDIF
      DO k = 1 , Nt
         DO j = 1 , nlon
            DO i = 1 , imm1
               G(i,j,k) = .5*(Ge(i,j,k)+Go(i,j,k))
               G(nlp1-i,j,k) = .5*(Ge(i,j,k)-Go(i,j,k))
            ENDDO
            IF ( modl/=0 ) G(Imid,j,k) = .5*Ge(Imid,j,k)
         ENDDO
      ENDDO
      RETURN
99999 END SUBROUTINE DSHSES1

      
      SUBROUTINE DSHSESI(Nlat,Nlon,Wshses,Lshses,Work,Lwork,Dwork,Ldwork,&
                      & Ierror)
      IMPLICIT NONE
      INTEGER Ierror , imid , iw1 , labc , Ldwork , lpimn , Lshses ,    &
            & Lwork , mmax , Nlat , Nlon
      DOUBLE PRECISION Work , Wshses
      DIMENSION Wshses(*) , Work(*)
      DOUBLE PRECISION Dwork(*)
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<4 ) RETURN
      Ierror = 3
      mmax = MIN0(Nlat,Nlon/2+1)
      imid = (Nlat+1)/2
      lpimn = (imid*mmax*(Nlat+Nlat-mmax+1))/2
      IF ( Lshses<lpimn+Nlon+15 ) RETURN
      Ierror = 4
      labc = 3*((mmax-2)*(Nlat+Nlat-mmax-1))/2
      IF ( Lwork<5*Nlat*imid+labc ) RETURN
      Ierror = 5
      IF ( Ldwork<Nlat+1 ) RETURN
      Ierror = 0
      iw1 = 3*Nlat*imid + 1
      CALL DSES1(Nlat,Nlon,imid,Wshses,Work,Work(iw1),Dwork)
      CALL DHRFFTI(Nlon,Wshses(lpimn+1))
    END SUBROUTINE DSHSESI


      
