C Copyright 1981-2012 ECMWF.
C
C This software is licensed under the terms of the Apache Licence 
C Version 2.0 which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
C
C In applying this licence, ECMWF does not waive the privileges and immunities 
C granted to it by virtue of its status as an intergovernmental organisation 
C nor does it submit to any jurisdiction.
C

      INTEGER FUNCTION SPROTAT(INGRIB,INLEN,SLON,SLAT,OUTGRIB,OUTLEN)
C
C---->
C**** SPROTAT
C
C     Purpose
C     -------
C
C     Rotates a spherical harmonic field.
C
C
C     Interface
C     ---------
C
C     IRET = SPROTAT(INGRIB,INLEN,SLON,SLAT,OUTGRIB,OUTLEN)
C
C     Input
C     -----
C
C     INGRIB  - Input GRIB field of spherical harmonics.
C     INLEN   - Length in bytes of the input GRIB.
C     SLON    - Longitude rotation required (degrees)
C     SLAT    - Latitude rotation required (degrees)
C
C
C     Output
C     ------
C
C     OUTGRIB  - Output GRIB field of rotated spherical harmonics.
C     OUTLEN   - Length in bytes of the output GRIB.
C
C     Function returns 0 if all OK, otherwise the rotation failed.
C
C
C     Method
C     ------
C
C     Externals
C     ---------
C
C     GRIBEX  - Decode/encode a GRIB product.
C     RPHI    - Rotates spectral coefficients by longitude.
C     JACOBI  - Rotates spectral coefficients by latitude.
C     INTLOG  - Logs messages.
C
C     Author
C     ------
C
C     J.D.Chambers         ECMWF     October, 1995.
C
C
C---------------------------------------------------------------------
C----<
C
      IMPLICIT NONE
#include "parim.h"
C
C     Parameters
      INTEGER JPROUTINE
      PARAMETER (JPROUTINE = 28300)
      INTEGER JPLEN, JPNM
      PARAMETER ( JPNM = JPSTRUNC )
      PARAMETER ( JPLEN = (JPNM+1)*(JPNM+2) )
C
C     Function arguments.
      INTEGER INGRIB, INLEN, OUTGRIB, OUTLEN
      DIMENSION INGRIB(*), OUTGRIB(*)
      REAL SLON, SLAT
C
C     Local variables
      INTEGER KSEC0, KSEC1, KSEC2, KSEC3, KSEC4, KWORD, KLENP, KLENG
      DIMENSION KSEC0(2),KSEC1(512),KSEC2(512),KSEC3(2),KSEC4(512)
      REAL PSEC4, PSEC2, PSEC3
      DIMENSION PSEC2(512),PSEC3(2),PSEC4(JPLEN)
      REAL*8 DLON, DLAT
      REAL*8 WORK
      DIMENSION WORK(2*(JPNM+1)*(JPNM+6))
      INTEGER ITRUNC, IRET, NBYTES, LOOP
      LOGICAL LOK
      REAL*8 DATA
      DIMENSION DATA(JPLEN)
C
      DATA NBYTES/4/
C
C     Externals
      LOGICAL JACOBI
      EXTERNAL JACOBI
C
C     _______________________________________________________
C
C*    Section 1. Initialise.
C     _______________________________________________________
C
  100 CONTINUE
C
      SPROTAT = 0
      IRET    = 0
#if (defined REAL_8)
      DLON = SLON
      DLAT = -90.0 - SLAT
#else
      DLON = DBLE(SLON)
      DLAT = -90.0 - DBLE(SLAT)
#endif
C
C     Decode the field.
      KLENP = JPLEN
      KLENG = (INLEN+NBYTES-1)/NBYTES
      IRET  = 1
      CALL GRIBEX(KSEC0, KSEC1, KSEC2, PSEC2, KSEC3, PSEC3, KSEC4, 
     X            PSEC4, KLENP, INGRIB, KLENG, KWORD, 'D' , IRET )
      IF(IRET.NE.0)THEN
        CALL INTLOG(JP_FATAL,'SPROTAT: Error decoding GRIB,IRET=', IRET)
        SPROTAT = JPROUTINE + 1
        GOTO 900
      ENDIF
C
C     Check that it really is a spherical harmonic field.
      IF( (KSEC2(1).NE.50) .AND. (KSEC2(1).NE.60) ) THEN
        CALL INTLOG(JP_FATAL,'SPROTAT: GRIB field not spectral',JPQUIET)
        CALL INTLOG(JP_FATAL,'SPROTAT: GRIB KSEC2(1) = ', KSEC2(1))
        SPROTAT = JPROUTINE + 2
        GOTO 900
      ENDIF
C
      ITRUNC = KSEC2(2)
C
C     _______________________________________________________
C
C*    Section 2. Rotate the spectral coefficients.
C     _______________________________________________________
C
  200 CONTINUE
C
#if (defined REAL_8)
C*********************************************************************
C
C     (REALs are already double precision)
C
C     Rotate the spectral field by longitude.
C     Positive DLON => frame rotated from west to east.
C
      CALL RPHI( PSEC4, ITRUNC, WORK, DLON)
C
C     Rotate the spectral field by latitude.
C     Negative DLAT => rotate counter-clockwise about new polar axis.
C
      LOK = JACOBI ( PSEC4, ITRUNC, WORK, DLAT)
#else
C*********************************************************************
C
C     (REALs are single precision)
C
C     Expand spectral coefficients to REAL*8
      DO 210 LOOP = 1, KSEC4(1)
        DATA(LOOP) = DBLE(PSEC4(LOOP))
  210 CONTINUE
C
C     Rotate the spectral field by longitude.
C     Positive DLON => frame rotated from west to east.
C
      CALL RPHI( DATA, ITRUNC, WORK, DLON)
C
C     Rotate the spectral field by latitude.
C     Negative DLAT => rotate counter-clockwise about new polar axis.
C
      LOK = JACOBI ( DATA, ITRUNC, WORK, DLAT)
      IF(.NOT.LOK) THEN
        CALL INTLOG(JP_FATAL,'SPROTAT: JACOBI failed.', JPQUIET)
        SPROTAT = JPROUTINE + 3
        GOTO 900
      ENDIF
C
C     Repack spectral coefficients to REAL*4.
      DO 220 LOOP = 1, KSEC4(1)
        PSEC4(LOOP) = SNGL(DATA(LOOP))
  220 CONTINUE
C*********************************************************************
#endif
C
C     _______________________________________________________
C
C*    Section 3. Repack the spectral coefficients.
C     _______________________________________________________
C
  300 CONTINUE
C
C     Put in details of southern pole of rotation
      KSEC2(13) = NINT(SLAT*1000.0)
      KSEC2(14) = NINT(SLON*1000.0)
C
C     Put in indicator to show field has been rotated ..
      KSEC2(1) = 60
C
C     .. unless south pole of rotation is (0,-90).
      IF( (KSEC2(14).EQ.0) .AND. (KSEC2(13).EQ.-90000) ) KSEC2(1) = 50
C
C     Encode the field.
      KLENP = KSEC4(1)
      KLENG = (OUTLEN+NBYTES-1)/NBYTES
      IRET  = 1
      CALL GRIBEX(KSEC0, KSEC1, KSEC2, PSEC2, KSEC3, PSEC3, KSEC4, 
     X            PSEC4, KLENP, OUTGRIB, KLENG, KWORD, 'C' , IRET )
      IF(IRET.NE.0)THEN
        CALL INTLOG(JP_FATAL,'SPROTAT: Error encoding GRIB,IRET=', IRET)
        SPROTAT = JPROUTINE + 4
        GOTO 900
      ENDIF
      OUTLEN = KSEC0(1)
C
C     _______________________________________________________
C
C*    Section 9. Return.
C     _______________________________________________________
C
  900 CONTINUE
C
      RETURN
      END
