!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         SPHEREPACK3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
!
! ... file vshifte.f contains code and documentation for subroutine vshifte
!     and its initialization subroutine vshifti
!
! ... required files
!
!     hrfft.f
!
!     subroutine vshifte(ioff,nlon,nlat,uoff,voff,ureg,vreg,
!    +                   wsave,lsave,work,lwork,ierror)
!
! *** purpose
!
!     subroutine vshifte does a highly accurate 1/2 grid increment shift
!     in both longitude and latitude of equally spaced vector data on the
!     sphere. data is transferred between the nlon by nlat "offset grid"
!     in (uoff,voff) (which excludes poles) and the nlon by nlat+1 "regular
!     grid" in (ureg,vreg) (which includes poles).  the transfer can go from
!     (uoff,voff) to (ureg,vreg) or vice versa (see ioff).  the grids which
!     underly the vector fields are described below.  the north and south
!     pole are at 0.5*pi and-0.5*pi radians respectively (pi=4.*atan(1.)).
!     uoff and ureg are the east longitudinal vector data components.  voff
!     and vreg are the latitudinal vector data components.
!
!     subroutine sshifte can be used to shift scalar data on the sphere.
!     notice that scalar and vector quantities are fundamentally different
!     on the sphere.  for example, vectors are discontinuous and multiple
!     valued at the poles.  scalars are continuous and single valued at the
!     poles. erroneous results would be produced if one attempted to shift
!     vector fields with subroutine sshifte applied to each component of
!     of the vector.
!
! *** grid descriptions
!
!     let dlon = (pi+pi)/nlon and dlat = pi/nlat be the uniform grid
!     increments in longitude and latitude
!
!     offset grid
!
!     the "1/2 increment offset" grid (long(j),lat(i)) on which uoff(j,i)
!     and voff(j,i) are given (ioff=0) or generated (ioff=1) is
!
!          long(j) =0.5*dlon + (j-1)*dlon  (j=1,...,nlon)
!
!     and
!
!          lat(i) = -0.5*pi + 0.5*dlat + (i-1)*dlat (i=1,...,nlat)
!
!     the data in (uoff,voff) is "shifted" one half a grid increment in both
!     longitude and latitude and excludes the poles.  each uoff(j,1),voff(j,1)
!     is given at latitude -pi/2+dlat/2.  uoff(j,nlat),voff(j,nlat) is
!     given at pi/2-dlat/2 (1/2 a grid increment away from the poles).
!     uoff(1,i),voff(1,i) is given at longitude dlon/2.  each uoff(nlon,i),
!     voff(nlon,i) is given at longitude 2*pi-dlon/2.
!
!     regular grid
!
!     let dlat,dlon be as above.  then the nlon by nlat+1 grid on which
!     ureg(j,i),vreg(j,i) are generated (ioff=0) or given (ioff=1) is
!
!          lone(j) = (j-1)*dlon (j=1,...,nlon)
!
!      and
!
!          late(i) = -0.5*pi + (i-1)*dlat (i=1,...,nlat+1)
!
!     values in ureg,vreg include the poles and start at zero degrees
!     longitude and at the south pole this is the "usual" equally spaced
!     grid in geophysical coordinates.
!
! *** remark
!
!     subroutine vshifte can be used in conjunction with subroutine trvsph
!     when transferring vector data from an equally spaced "1/2 increment
!     offset" grid to a gaussian or equally spaced grid (which includes poles)
!     of any resolution.  this problem (personal communication with dennis
!     shea) is encountered in geophysical modeling and data analysis.
!
! *** method
!
!     fast fourier transform software from spherepack2 and trigonometric
!     identities are used to accurately "shift" periodic vectors half a
!     grid increment in latitude and longitude.  latitudinal shifts are
!     accomplished by setting periodic 2*nlat vectors over the pole for each
!     longitude.  vector values must be negated on one side of the pole
!     to maintain periodicity prior to the 2*nlat shift over the poles.
!     when nlon is odd, the 2*nlat latitudinal shift requires an additional
!     longitude shift to obtain symmetry necessary for full circle shifts
!     over the poles.  finally longitudinal shifts are executed for each
!     shifted latitude.
!
! *** argument description
!
! ... ioff
!
!     ioff = 0 if values on the offset grid in (uoff,voff) are given and
!              values on the regular grid in (ureg,vreg) are to be generated.
!
!     ioff = 1 if values on the regular grid in (ureg,vreg) are given and
!              values on the offset grid in (uoff,voff) are to be generated.
!
! ... nlon
!
!     the number of longitude points on both the "offset" and "regular"
!     uniform grid in longitude (see "grid description" above).  nlon
!     is also the first dimension of uoff,voff,ureg,vreg.  nlon determines
!     the grid increment in longitude as dlon = 2.*pi/nlon.  for example,
!     nlon = 144 for a 2.5 degree grid.  nlon can be even or odd and must
!     be greater than or equal to 4.  the efficiency of the computation
!     is improved when nlon is a product of small primes.
!
! ... nlat
!
!     the number of latitude points on the "offset" uniform grid.  nlat+1
!     is the number of latitude points on the "regular" uniform grid (see
!     "grid description" above).  nlat is the second dimension of uoff,voff.
!     nlat+1 must be the second dimension of ureg,vreg in the program
!     calling vshifte.  nlat determines the grid in latitude as pi/nlat.
!     for example, nlat = 36 for a five degree grid.  nlat must be at least 3.
!
! ... uoff
!
!     a nlon by nlat array that contains the east longitudinal vector
!     data component on the offset grid described above.  uoff is a
!     given input argument if ioff=0.  uoff is a generated output
!     argument if ioff=1.
!
! ... voff
!
!     a nlon by nlat array that contains the latitudinal vector data
!     component on the offset grid described above.  voff is a given
!     input argument if ioff=0.  voff is a generated output argument
!     if ioff=1.
!
! ... ureg
!
!     a nlon by nlat+1 array that contains the east longitudinal vector
!     data component on the regular grid described above.  ureg is a given
!     input argument if ioff=1.  ureg is a generated output argument
!     if ioff=0.
!
! ... vreg
!
!     a nlon by nlat+1 array that contains the latitudinal vector data
!     component on the regular grid described above.  vreg is a given
!     input argument if ioff=1.  vreg is a generated output argument
!     if ioff=0.
!
! ... wsav
!
!     a real saved work space array that must be initialized by calling
!     subroutine vshifti(ioff,nlon,nlat,wsav,ier) before calling vshifte.
!     wsav can then be used repeatedly by vshifte as long as ioff, nlon,
!     and nlat do not change.  this bypasses redundant computations and
!     saves time.  undetectable errors will result if vshifte is called
!     without initializing wsav whenever ioff, nlon, or nlat change.
!
! ... lsav
!
!     the length of the saved work space wsav in the routine calling vshifte
!     and sshifti.  lsave must be greater than or equal to 2*(2*nlat+nlon+16).
!
! ... work
!
!     a real unsaved work space
!
! ... lwork
!
!     the length of the unsaved work space in the routine calling vshifte
!     if nlon is even then lwork must be greater than or equal to
!
!          2*nlon*(nlat+1)
!
!     if nlon is odd then lwork must be greater than or equal to
!
!          nlon*(5*nlat+1)
!
! ... ier
!
!     indicates errors in input parameters
!
!     = 0 if no errors are detected
!
!     = 1 if ioff is not equal to 0 or 1
!
!     = 2 if nlon < 4
!
!     = 3 if nlat < 3
!
!     = 4 if lsave < 2*(nlon+2*nlat)+32
!
!     = 5 if lwork < 2*nlon*(nlat+1) for nlon even or
!            lwork < nlon*(5*nlat+1) for nlon odd
!
! *** end of vshifte documentation
!
!     subroutine vshifti(ioff,nlon,nlat,lsav,wsav,ier)
!
!     subroutine vshifti initializes the saved work space wsav
!     for ioff and nlon and nlat (see documentation for vshifte).
!     vshifti must be called before vshifte whenever ioff or nlon
!     or nlat change.
!
! ... ier
!
!     = 0 if no errors with input arguments
!
!     = 1 if ioff is not 0 or 1
!
!     = 2 if nlon < 4
!
!     = 3 if nlat < 3
!
!     = 4 if lsav < 2*(2*nlat+nlon+16)
!
! *** end of vshifti documentation
!
      SUBROUTINE VSHIFTE(Ioff,Nlon,Nlat,Uoff,Voff,Ureg,Vreg,Wsav,Lsav,  &
                       & Wrk,Lwrk,Ier)
      IMPLICIT NONE
!*--VSHIFTE237
      INTEGER Ioff , Nlon , Nlat , n2 , nr , nlat2 , nlatp1 , Lsav ,    &
            & Lwrk , Ier
      INTEGER i1 , i2 , i3
      REAL Uoff(Nlon,Nlat) , Voff(Nlon,Nlat)
      REAL Ureg(Nlon,*) , Vreg(Nlon,*)
      REAL Wsav(Lsav) , Wrk(Lwrk)
!
!     check input parameters
!
      Ier = 1
      IF ( Ioff*(Ioff-1)/=0 ) RETURN
      Ier = 2
      IF ( Nlon<4 ) RETURN
      Ier = 3
      IF ( Nlat<3 ) RETURN
      Ier = 4
      IF ( Lsav<2*(2*Nlat+Nlon+16) ) RETURN
      nlat2 = Nlat + Nlat
      nlatp1 = Nlat + 1
      n2 = (Nlon+1)/2
      Ier = 5
      IF ( 2*n2==Nlon ) THEN
         IF ( Lwrk<2*Nlon*(Nlat+1) ) RETURN
         nr = n2
         i1 = 1
         i2 = 1
         i3 = i2 + Nlon*nlatp1
      ELSE
         IF ( Lwrk<Nlon*(5*Nlat+1) ) RETURN
         nr = Nlon
         i1 = 1
         i2 = i1 + nlat2*Nlon
         i3 = i2 + nlatp1*Nlon
      ENDIF
      Ier = 0
      IF ( Ioff==0 ) THEN
!
!     shift (uoff,voff) to (ureg,vreg)
!
         CALL VHFTOFF(Nlon,Nlat,Uoff,Ureg,Wsav,nr,nlat2,nlatp1,Wrk(i1), &
                    & Wrk(i2),Wrk(i2),Wrk(i3))
         CALL VHFTOFF(Nlon,Nlat,Voff,Vreg,Wsav,nr,nlat2,nlatp1,Wrk(i1), &
                    & Wrk(i2),Wrk(i2),Wrk(i3))
      ELSE
!
!     shift (ureg,vreg) to (uoff,voff)
!
         CALL VHFTREG(Nlon,Nlat,Uoff,Ureg,Wsav,nr,nlat2,nlatp1,Wrk(i1), &
                    & Wrk(i2),Wrk(i2),Wrk(i3))
         CALL VHFTREG(Nlon,Nlat,Voff,Vreg,Wsav,nr,nlat2,nlatp1,Wrk(i1), &
                    & Wrk(i2),Wrk(i2),Wrk(i3))
      ENDIF
      END SUBROUTINE VSHIFTE

      
      SUBROUTINE VHFTOFF(Nlon,Nlat,Uoff,Ureg,Wsav,Nr,Nlat2,Nlatp1,Rlatu,&
                       & Rlonu,Rlou,Wrk)
!
!     generate ureg from uoff (a vector component!)
!
      IMPLICIT NONE
!*--VHFTOFF299
      INTEGER Nlon , Nlat , Nlat2 , Nlatp1 , n2 , Nr , j , i , js , isav
      REAL Uoff(Nlon,Nlat) , Ureg(Nlon,Nlatp1)
      REAL Rlatu(Nr,Nlat2) , Rlonu(Nlatp1,Nlon) , Rlou(Nlat,Nlon)
      REAL Wsav(*) , Wrk(*)
      isav = 4*Nlat + 17
      n2 = (Nlon+1)/2
!
!     execute full circle latitude shifts for nlon odd or even
!
      IF ( 2*n2>Nlon ) THEN
!
!     odd number of longitudes
!
         DO i = 1 , Nlat
            DO j = 1 , Nlon
               Rlou(i,j) = Uoff(j,i)
            ENDDO
         ENDDO
!
!       half shift in longitude
!
         CALL VHIFTH(Nlat,Nlon,Rlou,Wsav(isav),Wrk)
!
!       set full 2*nlat circles in rlatu using shifted values in rlonu
!
         DO j = 1 , n2 - 1
            js = j + n2
            DO i = 1 , Nlat
               Rlatu(j,i) = Uoff(j,i)
               Rlatu(j,Nlat+i) = -Rlou(Nlat+1-i,js)
            ENDDO
         ENDDO
         DO j = n2 , Nlon
            js = j - n2 + 1
            DO i = 1 , Nlat
               Rlatu(j,i) = Uoff(j,i)
               Rlatu(j,Nlat+i) = -Rlou(Nlat+1-i,js)
            ENDDO
         ENDDO
!
!       shift the nlon rlat vectors one half latitude grid
!
         CALL VHIFTH(Nlon,Nlat2,Rlatu,Wsav,Wrk)
!
!       set in ureg
!
         DO j = 1 , Nlon
            DO i = 1 , Nlat + 1
               Ureg(j,i) = Rlatu(j,i)
            ENDDO
         ENDDO
      ELSE
!
!     even number of longitudes (no initial longitude shift necessary)
!     set full 2*nlat circles (over poles) for each longitude pair (j,js)
!     negating js vector side for periodicity
!
         DO j = 1 , n2
            js = n2 + j
            DO i = 1 , Nlat
               Rlatu(j,i) = Uoff(j,i)
               Rlatu(j,Nlat+i) = -Uoff(js,Nlatp1-i)
            ENDDO
         ENDDO
!
!       shift the n2=(nlon+1)/2 rlat vectors one half latitude grid
!
         CALL VHIFTH(n2,Nlat2,Rlatu,Wsav,Wrk)
!
!       set ureg,vreg shifted in latitude
!
         DO j = 1 , n2
            js = n2 + j
            Ureg(j,1) = Rlatu(j,1)
            Ureg(js,1) = -Rlatu(j,1)
            DO i = 2 , Nlatp1
               Ureg(j,i) = Rlatu(j,i)
               Ureg(js,i) = -Rlatu(j,Nlat2-i+2)
            ENDDO
         ENDDO
      ENDIF
!
!     execute full circle longitude shift
!
      DO j = 1 , Nlon
         DO i = 1 , Nlatp1
            Rlonu(i,j) = Ureg(j,i)
         ENDDO
      ENDDO
      CALL VHIFTH(Nlatp1,Nlon,Rlonu,Wsav(isav),Wrk)
      DO j = 1 , Nlon
         DO i = 1 , Nlatp1
            Ureg(j,i) = Rlonu(i,j)
         ENDDO
      ENDDO
      END SUBROUTINE VHFTOFF
      
 
      SUBROUTINE VHFTREG(Nlon,Nlat,Uoff,Ureg,Wsav,Nr,Nlat2,Nlatp1,Rlatu,&
                       & Rlonu,Rlou,Wrk)
!
!     generate uoff vector component from ureg
!
      IMPLICIT NONE
      INTEGER Nlon , Nlat , Nlat2 , Nlatp1 , n2 , Nr , j , i , js , isav
      REAL Uoff(Nlon,Nlat) , Ureg(Nlon,Nlatp1)
      REAL Rlatu(Nr,Nlat2) , Rlonu(Nlatp1,Nlon) , Rlou(Nlat,Nlon)
      REAL Wsav(*) , Wrk(*)
      isav = 4*Nlat + 17
      n2 = (Nlon+1)/2
!
!     execute full circle latitude shifts for nlon odd or even
!
      IF ( 2*n2>Nlon ) THEN
!
!     odd number of longitudes
!
         DO i = 1 , Nlatp1
            DO j = 1 , Nlon
               Rlonu(i,j) = Ureg(j,i)
            ENDDO
         ENDDO
!
!       half shift in longitude in rlon
!
         CALL VHIFTH(Nlatp1,Nlon,Rlonu,Wsav(isav),Wrk)
!
!       set full 2*nlat circles in rlat using shifted values in rlon
!
         DO j = 1 , n2
            js = j + n2 - 1
            Rlatu(j,1) = Ureg(j,1)
            DO i = 2 , Nlat
               Rlatu(j,i) = Ureg(j,i)
               Rlatu(j,Nlat+i) = -Rlonu(Nlat+2-i,js)
            ENDDO
            Rlatu(j,Nlat+1) = Ureg(j,Nlat+1)
         ENDDO
         DO j = n2 + 1 , Nlon
            js = j - n2
            Rlatu(j,1) = Ureg(j,1)
            DO i = 2 , Nlat
               Rlatu(j,i) = Ureg(j,i)
               Rlatu(j,Nlat+i) = -Rlonu(Nlat+2-i,js)
            ENDDO
            Rlatu(j,Nlat+1) = Ureg(j,Nlat+1)
         ENDDO
!
!       shift the nlon rlat vectors one halflatitude grid
!
         CALL VHIFTH(Nlon,Nlat2,Rlatu,Wsav,Wrk)
!
!       set values in uoff
!
         DO j = 1 , Nlon
            DO i = 1 , Nlat
               Uoff(j,i) = Rlatu(j,i)
            ENDDO
         ENDDO
      ELSE
!
!     even number of longitudes (no initial longitude shift necessary)
!     set full 2*nlat circles (over poles) for each longitude pair (j,js)
!
         DO j = 1 , n2
            js = n2 + j
            Rlatu(j,1) = Ureg(j,1)
            DO i = 2 , Nlat
               Rlatu(j,i) = Ureg(j,i)
               Rlatu(j,Nlat+i) = -Ureg(js,Nlat+2-i)
            ENDDO
            Rlatu(j,Nlat+1) = Ureg(j,Nlat+1)
         ENDDO
!
!       shift the n2=(nlon+1)/2 rlat vectors one half latitude grid
!
         CALL VHIFTH(n2,Nlat2,Rlatu,Wsav,Wrk)
!
!       set values in uoff
!
         DO j = 1 , n2
            js = n2 + j
            DO i = 1 , Nlat
               Uoff(j,i) = Rlatu(j,i)
               Uoff(js,i) = -Rlatu(j,Nlat2+1-i)
            ENDDO
         ENDDO
      ENDIF
!
!     execute full circle longitude shift for all latitude circles
!
      DO j = 1 , Nlon
         DO i = 1 , Nlat
            Rlou(i,j) = Uoff(j,i)
         ENDDO
      ENDDO
      CALL VHIFTH(Nlat,Nlon,Rlou,Wsav(isav),Wrk)
      DO j = 1 , Nlon
         DO i = 1 , Nlat
            Uoff(j,i) = Rlou(i,j)
         ENDDO
      ENDDO
      END SUBROUTINE VHFTREG
 

      SUBROUTINE VSHIFTI(Ioff,Nlon,Nlat,Lsav,Wsav,Ier)
      IMPLICIT NONE
      INTEGER Lsav
!
!     initialize wsav for vshifte
!
      INTEGER Ioff , Nlat , Nlon , nlat2 , isav , Ier
      REAL Wsav(Lsav)
      REAL pi , dlat , dlon , dp
      Ier = 1
      IF ( Ioff*(Ioff-1)/=0 ) RETURN
      Ier = 2
      IF ( Nlon<4 ) RETURN
      Ier = 3
      IF ( Nlat<3 ) RETURN
      Ier = 4
      IF ( Lsav<2*(2*Nlat+Nlon+16) ) RETURN
      Ier = 0
      pi = 4.0*ATAN(1.0)
!
!     set lat,long increments
!
      dlat = pi/Nlat
      dlon = (pi+pi)/Nlon
!
!     set left or right latitude shifts
!
      IF ( Ioff==0 ) THEN
         dp = -0.5*dlat
      ELSE
         dp = 0.5*dlat
      ENDIF
      nlat2 = Nlat + Nlat
      CALL VHIFTHI(nlat2,dp,Wsav)
!
!     set left or right longitude shifts
!
      IF ( Ioff==0 ) THEN
         dp = -0.5*dlon
      ELSE
         dp = 0.5*dlon
      ENDIF
      isav = 4*Nlat + 17
      CALL VHIFTHI(Nlon,dp,Wsav(isav))
      END

      
      SUBROUTINE VHIFTH(M,N,R,Wsav,Work)
      IMPLICIT NONE
      INTEGER M , N , n2 , k , l
      REAL R(M,N) , Wsav(*) , Work(*) , r2km2 , r2km1
      n2 = (N+1)/2
!
!     compute fourier coefficients for r on shifted grid
!
      CALL HRFFTF(M,N,R,M,Wsav(N+2),Work)
      DO l = 1 , M
         DO k = 2 , n2
            r2km2 = R(l,k+k-2)
            r2km1 = R(l,k+k-1)
            R(l,k+k-2) = r2km2*Wsav(n2+k) - r2km1*Wsav(k)
            R(l,k+k-1) = r2km2*Wsav(k) + r2km1*Wsav(n2+k)
         ENDDO
      ENDDO
!
!     shift r with fourier synthesis and normalization
!
      CALL HRFFTB(M,N,R,M,Wsav(N+2),Work)
      DO l = 1 , M
         DO k = 1 , N
            R(l,k) = R(l,k)/N
         ENDDO
      ENDDO
      END SUBROUTINE VHIFTH

      
      SUBROUTINE VHIFTHI(N,Dp,Wsav)
!
!     initialize wsav for subroutine vhifth
!
      IMPLICIT NONE
!*--VHIFTHI591
      INTEGER N , n2 , k
      REAL Wsav(*) , Dp
      n2 = (N+1)/2
      DO k = 2 , n2
         Wsav(k) = SIN((k-1)*Dp)
         Wsav(k+n2) = COS((k-1)*Dp)
      ENDDO
      CALL HRFFTI(N,Wsav(N+2))
      END SUBROUTINE VHIFTHI


      SUBROUTINE DVSHIFTE(Ioff,Nlon,Nlat,Uoff,Voff,Ureg,Vreg,Wsav,Lsav,  &
                       & Wrk,Lwrk,Ier)
      IMPLICIT NONE
      INTEGER Ioff , Nlon , Nlat , n2 , nr , nlat2 , nlatp1 , Lsav ,    &
            & Lwrk , Ier
      INTEGER i1 , i2 , i3
      DOUBLE PRECISION Uoff(Nlon,Nlat) , Voff(Nlon,Nlat)
      DOUBLE PRECISION Ureg(Nlon,*) , Vreg(Nlon,*)
      DOUBLE PRECISION Wsav(Lsav) , Wrk(Lwrk)
!
!     check input parameters
!
      Ier = 1
      IF ( Ioff*(Ioff-1)/=0 ) RETURN
      Ier = 2
      IF ( Nlon<4 ) RETURN
      Ier = 3
      IF ( Nlat<3 ) RETURN
      Ier = 4
      IF ( Lsav<2*(2*Nlat+Nlon+16) ) RETURN
      nlat2 = Nlat + Nlat
      nlatp1 = Nlat + 1
      n2 = (Nlon+1)/2
      Ier = 5
      IF ( 2*n2==Nlon ) THEN
         IF ( Lwrk<2*Nlon*(Nlat+1) ) RETURN
         nr = n2
         i1 = 1
         i2 = 1
         i3 = i2 + Nlon*nlatp1
      ELSE
         IF ( Lwrk<Nlon*(5*Nlat+1) ) RETURN
         nr = Nlon
         i1 = 1
         i2 = i1 + nlat2*Nlon
         i3 = i2 + nlatp1*Nlon
      ENDIF
      Ier = 0
      IF ( Ioff==0 ) THEN
!
!     shift (uoff,voff) to (ureg,vreg)
!
         CALL DVHFTOFF(Nlon,Nlat,Uoff,Ureg,Wsav,nr,nlat2,nlatp1,Wrk(i1), &
                    & Wrk(i2),Wrk(i2),Wrk(i3))
         CALL DVHFTOFF(Nlon,Nlat,Voff,Vreg,Wsav,nr,nlat2,nlatp1,Wrk(i1), &
                    & Wrk(i2),Wrk(i2),Wrk(i3))
      ELSE
!
!     shift (ureg,vreg) to (uoff,voff)
!
         CALL DVHFTREG(Nlon,Nlat,Uoff,Ureg,Wsav,nr,nlat2,nlatp1,Wrk(i1), &
                    & Wrk(i2),Wrk(i2),Wrk(i3))
         CALL DVHFTREG(Nlon,Nlat,Voff,Vreg,Wsav,nr,nlat2,nlatp1,Wrk(i1), &
                    & Wrk(i2),Wrk(i2),Wrk(i3))
      ENDIF
      END SUBROUTINE DVSHIFTE

      
      SUBROUTINE DVHFTOFF(Nlon,Nlat,Uoff,Ureg,Wsav,Nr,Nlat2,Nlatp1,Rlatu,&
                       & Rlonu,Rlou,Wrk)
!
!     generate ureg from uoff (a vector component!)
!
      IMPLICIT NONE
      INTEGER Nlon , Nlat , Nlat2 , Nlatp1 , n2 , Nr , j , i , js , isav
      DOUBLE PRECISION Uoff(Nlon,Nlat) , Ureg(Nlon,Nlatp1)
      DOUBLE PRECISION Rlatu(Nr,Nlat2) , Rlonu(Nlatp1,Nlon) , Rlou(Nlat,Nlon)
      DOUBLE PRECISION Wsav(*) , Wrk(*)
      isav = 4*Nlat + 17
      n2 = (Nlon+1)/2
!
!     execute full circle latitude shifts for nlon odd or even
!
      IF ( 2*n2>Nlon ) THEN
!
!     odd number of longitudes
!
         DO i = 1 , Nlat
            DO j = 1 , Nlon
               Rlou(i,j) = Uoff(j,i)
            ENDDO
         ENDDO
!
!       half shift in longitude
!
         CALL DVHIFTH(Nlat,Nlon,Rlou,Wsav(isav),Wrk)
!
!       set full 2*nlat circles in rlatu using shifted values in rlonu
!
         DO j = 1 , n2 - 1
            js = j + n2
            DO i = 1 , Nlat
               Rlatu(j,i) = Uoff(j,i)
               Rlatu(j,Nlat+i) = -Rlou(Nlat+1-i,js)
            ENDDO
         ENDDO
         DO j = n2 , Nlon
            js = j - n2 + 1
            DO i = 1 , Nlat
               Rlatu(j,i) = Uoff(j,i)
               Rlatu(j,Nlat+i) = -Rlou(Nlat+1-i,js)
            ENDDO
         ENDDO
!
!       shift the nlon rlat vectors one half latitude grid
!
         CALL DVHIFTH(Nlon,Nlat2,Rlatu,Wsav,Wrk)
!
!       set in ureg
!
         DO j = 1 , Nlon
            DO i = 1 , Nlat + 1
               Ureg(j,i) = Rlatu(j,i)
            ENDDO
         ENDDO
      ELSE
!
!     even number of longitudes (no initial longitude shift necessary)
!     set full 2*nlat circles (over poles) for each longitude pair (j,js)
!     negating js vector side for periodicity
!
         DO j = 1 , n2
            js = n2 + j
            DO i = 1 , Nlat
               Rlatu(j,i) = Uoff(j,i)
               Rlatu(j,Nlat+i) = -Uoff(js,Nlatp1-i)
            ENDDO
         ENDDO
!
!       shift the n2=(nlon+1)/2 rlat vectors one half latitude grid
!
         CALL DVHIFTH(n2,Nlat2,Rlatu,Wsav,Wrk)
!
!       set ureg,vreg shifted in latitude
!
         DO j = 1 , n2
            js = n2 + j
            Ureg(j,1) = Rlatu(j,1)
            Ureg(js,1) = -Rlatu(j,1)
            DO i = 2 , Nlatp1
               Ureg(j,i) = Rlatu(j,i)
               Ureg(js,i) = -Rlatu(j,Nlat2-i+2)
            ENDDO
         ENDDO
      ENDIF
!
!     execute full circle longitude shift
!
      DO j = 1 , Nlon
         DO i = 1 , Nlatp1
            Rlonu(i,j) = Ureg(j,i)
         ENDDO
      ENDDO
      CALL DVHIFTH(Nlatp1,Nlon,Rlonu,Wsav(isav),Wrk)
      DO j = 1 , Nlon
         DO i = 1 , Nlatp1
            Ureg(j,i) = Rlonu(i,j)
         ENDDO
      ENDDO
      END SUBROUTINE DVHFTOFF
      
 
      SUBROUTINE DVHFTREG(Nlon,Nlat,Uoff,Ureg,Wsav,Nr,Nlat2,Nlatp1,Rlatu,&
                       & Rlonu,Rlou,Wrk)
!
!     generate uoff vector component from ureg
!
      IMPLICIT NONE
      INTEGER Nlon , Nlat , Nlat2 , Nlatp1 , n2 , Nr , j , i , js , isav
      DOUBLE PRECISION Uoff(Nlon,Nlat) , Ureg(Nlon,Nlatp1)
      DOUBLE PRECISION Rlatu(Nr,Nlat2) , Rlonu(Nlatp1,Nlon) , Rlou(Nlat,Nlon)
      DOUBLE PRECISION Wsav(*) , Wrk(*)
      isav = 4*Nlat + 17
      n2 = (Nlon+1)/2
!
!     execute full circle latitude shifts for nlon odd or even
!
      IF ( 2*n2>Nlon ) THEN
!
!     odd number of longitudes
!
         DO i = 1 , Nlatp1
            DO j = 1 , Nlon
               Rlonu(i,j) = Ureg(j,i)
            ENDDO
         ENDDO
!
!       half shift in longitude in rlon
!
         CALL DVHIFTH(Nlatp1,Nlon,Rlonu,Wsav(isav),Wrk)
!
!       set full 2*nlat circles in rlat using shifted values in rlon
!
         DO j = 1 , n2
            js = j + n2 - 1
            Rlatu(j,1) = Ureg(j,1)
            DO i = 2 , Nlat
               Rlatu(j,i) = Ureg(j,i)
               Rlatu(j,Nlat+i) = -Rlonu(Nlat+2-i,js)
            ENDDO
            Rlatu(j,Nlat+1) = Ureg(j,Nlat+1)
         ENDDO
         DO j = n2 + 1 , Nlon
            js = j - n2
            Rlatu(j,1) = Ureg(j,1)
            DO i = 2 , Nlat
               Rlatu(j,i) = Ureg(j,i)
               Rlatu(j,Nlat+i) = -Rlonu(Nlat+2-i,js)
            ENDDO
            Rlatu(j,Nlat+1) = Ureg(j,Nlat+1)
         ENDDO
!
!       shift the nlon rlat vectors one halflatitude grid
!
         CALL DVHIFTH(Nlon,Nlat2,Rlatu,Wsav,Wrk)
!
!       set values in uoff
!
         DO j = 1 , Nlon
            DO i = 1 , Nlat
               Uoff(j,i) = Rlatu(j,i)
            ENDDO
         ENDDO
      ELSE
!
!     even number of longitudes (no initial longitude shift necessary)
!     set full 2*nlat circles (over poles) for each longitude pair (j,js)
!
         DO j = 1 , n2
            js = n2 + j
            Rlatu(j,1) = Ureg(j,1)
            DO i = 2 , Nlat
               Rlatu(j,i) = Ureg(j,i)
               Rlatu(j,Nlat+i) = -Ureg(js,Nlat+2-i)
            ENDDO
            Rlatu(j,Nlat+1) = Ureg(j,Nlat+1)
         ENDDO
!
!       shift the n2=(nlon+1)/2 rlat vectors one half latitude grid
!
         CALL DVHIFTH(n2,Nlat2,Rlatu,Wsav,Wrk)
!
!       set values in uoff
!
         DO j = 1 , n2
            js = n2 + j
            DO i = 1 , Nlat
               Uoff(j,i) = Rlatu(j,i)
               Uoff(js,i) = -Rlatu(j,Nlat2+1-i)
            ENDDO
         ENDDO
      ENDIF
!
!     execute full circle longitude shift for all latitude circles
!
      DO j = 1 , Nlon
         DO i = 1 , Nlat
            Rlou(i,j) = Uoff(j,i)
         ENDDO
      ENDDO
      CALL DVHIFTH(Nlat,Nlon,Rlou,Wsav(isav),Wrk)
      DO j = 1 , Nlon
         DO i = 1 , Nlat
            Uoff(j,i) = Rlou(i,j)
         ENDDO
      ENDDO
      END SUBROUTINE DVHFTREG
 

      SUBROUTINE DVSHIFTI(Ioff,Nlon,Nlat,Lsav,Wsav,Ier)
      IMPLICIT NONE
      INTEGER Lsav
!
!     initialize wsav for vshifte
!
      INTEGER Ioff , Nlat , Nlon , nlat2 , isav , Ier
      DOUBLE PRECISION Wsav(Lsav)
      DOUBLE PRECISION pi , dlat , dlon , dp
      Ier = 1
      IF ( Ioff*(Ioff-1)/=0 ) RETURN
      Ier = 2
      IF ( Nlon<4 ) RETURN
      Ier = 3
      IF ( Nlat<3 ) RETURN
      Ier = 4
      IF ( Lsav<2*(2*Nlat+Nlon+16) ) RETURN
      Ier = 0
      pi = 4.0*ATAN(1.0)
!
!     set lat,long increments
!
      dlat = pi/Nlat
      dlon = (pi+pi)/Nlon
!
!     set left or right latitude shifts
!
      IF ( Ioff==0 ) THEN
         dp = -0.5*dlat
      ELSE
         dp = 0.5*dlat
      ENDIF
      nlat2 = Nlat + Nlat
      CALL DVHIFTHI(nlat2,dp,Wsav)
!
!     set left or right longitude shifts
!
      IF ( Ioff==0 ) THEN
         dp = -0.5*dlon
      ELSE
         dp = 0.5*dlon
      ENDIF
      isav = 4*Nlat + 17
      CALL DVHIFTHI(Nlon,dp,Wsav(isav))
      END

      
      SUBROUTINE DVHIFTH(M,N,R,Wsav,Work)
      IMPLICIT NONE
      INTEGER M , N , n2 , k , l
      DOUBLE PRECISION R(M,N) , Wsav(*) , Work(*) , r2km2 , r2km1
      n2 = (N+1)/2
!
!     compute fourier coefficients for r on shifted grid
!
      CALL DHRFFTF(M,N,R,M,Wsav(N+2),Work)
      DO l = 1 , M
         DO k = 2 , n2
            r2km2 = R(l,k+k-2)
            r2km1 = R(l,k+k-1)
            R(l,k+k-2) = r2km2*Wsav(n2+k) - r2km1*Wsav(k)
            R(l,k+k-1) = r2km2*Wsav(k) + r2km1*Wsav(n2+k)
         ENDDO
      ENDDO
!
!     shift r with fourier synthesis and normalization
!
      CALL DHRFFTB(M,N,R,M,Wsav(N+2),Work)
      DO l = 1 , M
         DO k = 1 , N
            R(l,k) = R(l,k)/N
         ENDDO
      ENDDO
      END SUBROUTINE DVHIFTH

      
      SUBROUTINE DVHIFTHI(N,Dp,Wsav)
!
!     initialize wsav for subroutine vhifth
!
      IMPLICIT NONE
      INTEGER N , n2 , k
      DOUBLE PRECISION Wsav(*) , Dp
      n2 = (N+1)/2
      DO k = 2 , n2
         Wsav(k) = SIN((k-1)*Dp)
         Wsav(k+n2) = COS((k-1)*Dp)
      ENDDO
      CALL DHRFFTI(N,Wsav(N+2))
      END SUBROUTINE DVHIFTHI
