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 INTVECT(PUFIELD,PVFIELD,KASIZE,
     X                         KUGRIB,KVGRIB,OUTLEN)
C
C---->
C**** INTVECT
C
C     Purpose
C     -------
C     Interpolate U or V component fields to grid point.
C
C
C     Interface
C     ---------
C     IRET = INTVECT(PUFIELD,PVFIELD,KASIZE,
C    X               KUGRIB,KVGRIB,OUTLEN)
C
C     Input
C     -----
C     PUFIELD - U values.
C     PVFIELD - V values.
C     KASIZE  - Size of input arrays
C
C
C     Output
C     ------
C     KUGRIB - Output wind U component field (GRIB format).
C     KVGRIB - Output wind V component field (GRIB format).
C     OUTLEN - Output U field length (words).
C
C
C     Method
C     ------
C     None.
C
C
C     Externals
C     ---------
C     RESET_C - Reset interpolation handling options using GRIB product.
C     IBASINI - Ensure basic interpolation setup is done.
C     ISCRSZ  - Calculate number of values in generated field.
C     INTUVDH - Encode/decode data into/from GRIB code.
C     INTFAU  - Prepare to interpolate unpacked input field.
C     INTFBU  - Interpolate unpacked input field.
C     INTLOG  - Log error message.
C     MKFRAME - Create a 'frame' from a rectangular field.
C     INTUVGH - Interpolate GRIB U and V reduced gaussian to rotated GRIB
C               U and V.
C
C
C     Author
C     ------
C     J.D.Chambers     ECMWF     September 2004
C
C
C----<
C     -----------------------------------------------------------------|
C
      IMPLICIT NONE
C
#include "parim.h"
#include "nifld.common"
#include "nofld.common"
#include "intf.h"
#include "current.h"
C
C     Parameters
C
      INTEGER JPROUTINE
      PARAMETER (JPROUTINE = 40170 )
C
C     Function arguments
C
      INTEGER KPARAM, KASIZE, KUGRIB(*), KVGRIB(*), OUTLEN
      REAL PUFIELD(KASIZE), PVFIELD(KASIZE)
C
C     Local variables
C
      LOGICAL LFRAME, LOLDWIND, LOMISSV
      INTEGER NPARAM, IRET, ILENF, NTRUNC, NGAUSS, ISIZE, NCOUNT
      INTEGER NUVFLAG, NLON, NLAT, NBYTES, NSIZE
      INTEGER ISZVD, IHOLD, ISAME
      INTEGER IN_U, IN_V
      REAL DUMMY
      REAL AREA(4), GRID(2), POLE(2), EAST, WEST
      CHARACTER*1 HOLDTYP
      INTEGER LOOP
      INTEGER OUTLENO
C
      REAL RGGRID, SWORK, TWORK
      POINTER (IRGGRID, RGGRID(1) )
      POINTER (ISWORK, SWORK(1) )
      POINTER (ITWORK, TWORK(1) )
C
      INTEGER KPTS(JPGTRUNC*2)
      REAL GLATS(JPGTRUNC*2)

      LOGICAL LFIRST, LNEWUV, LSPECUV
      CHARACTER*3 EXTRA
C
C     Externals
C
      INTEGER FIXAREA, INTFAU, INTFBU, INTUVDH, HSP2GG, IBASINI
      INTEGER HIRLAMW, ISCRSZ, RESET_C, INSANE, INTUVGH
C
      DATA IRGGRID/0/, ISWORK/0/, ITWORK/0/
      SAVE IRGGRID, ISWORK, ITWORK
      DATA LFIRST/.TRUE./, LNEWUV/.TRUE./, EXTRA/'NO '/
      SAVE LFIRST, LNEWUV
C
C     -----------------------------------------------------------------|
C*    Section 1.   Initialise.
C     -----------------------------------------------------------------|
C
  100 CONTINUE
C
      INTVECT = 0


      IF( LFIRST ) THEN
        CALL GETENV('IGNORE_UV_EXTRA_MODE', EXTRA)
        IF((EXTRA(1:1).EQ.'Y').OR.(EXTRA(1:1).EQ.'y')) LNEWUV = .FALSE.
        IF( LNEWUV ) THEN
          CALL INTLOG(JP_DEBUG,
     X      'INTVECT: IGNORE_UV_EXTRA_MODE not turned on',JPQUIET)
        ELSE
          CALL INTLOG(JP_DEBUG,
     X      'INTVECT: IGNORE_UV_EXTRA_MODE turned on',JPQUIET)
        ENDIF
        LFIRST = .FALSE.
      ENDIF
C
      LOLDWIND = LWINDSET
C
C     Ensure that basic initialisation has been done
C
      IRET = IBASINI(0)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,'INTVECT: basic initialise failed',JPQUIET)
        INTVECT = IRET
        GOTO 900
      ENDIF
C
C     Unpack GRIB sections 1 and 2.
C
      ISZVD = 1
      IRET = INTUVDH(DUMMY,ISZVD,PUFIELD,KASIZE,'J',IN_U)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,'INTVECT: GRIB header decode failed',IRET)
        INTVECT = IRET
        GOTO 900
      ENDIF
      NSIZE = ISEC4(1)
      NIREPR = ISEC2(1)
      LSPECUV = (NIREPR.EQ.JPSPHERE).OR.(NIREPR.EQ.JPSPHROT)
      IF( LSPECUV ) NIRESO = ISEC2(2)
C
C     Setup interpolation options from input GRIB characteristics.
C
      IRET = RESET_C(ISEC1, ISEC2, ZSEC2, ISEC4)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT: Setup interp. options from GRIB failed.',JPQUIET)
        INTVECT = IRET
        GOTO 900
      ENDIF

      IF(NIREPR.EQ.JPREGROT) THEN
        OUTLEN = 0
        IRET   = 0
        CALL INTLOG(JP_DEBUG,
     X    'INTF: Input U and V rotated lat/long fields ...',JPQUIET)
        CALL INTLOG(JP_DEBUG,
     X    'INTF: ... no interpolation has been done',JPQUIET)
        GOTO 900
      ENDIF
C
C       Only allowed rotations are:
C        - spectral to regular lat/long
C        - reduced gaussian to regular lat/long
C
      IF( LNOROTA ) THEN
        IF( ((NOREPR.NE.JPREGROT).AND.(NOREPR.NE.JPREGULAR)).OR.
     X      ((NIREPR.NE.JPSPHERE).AND.(NIREPR.NE.JPQUASI)) ) THEN
          CALL INTLOG(JP_ERROR,
     X      'INTVECT: For vector fields, only allowed rotations are:',
     X      JPQUIET)
          CALL INTLOG(JP_ERROR,
     X      'INTVECT: spectral to regular lat/long, or',JPQUIET)
          CALL INTLOG(JP_ERROR,
     X      'INTVECT: reduced gaussian to regular lat/long',JPQUIET)
          INTVECT = JPROUTINE + 1
          GOTO 900
        ENDIF
      ENDIF
C
C     Check that no outrageous values given for interpolation
C
      ISAME = INSANE()
      IF( (ISAME.GT.0).AND.(ISAME.NE.27261) ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT: Interpolation cannot use given values.',JPQUIET)
        INTVECT = ISAME
        GOTO 900
      ENDIF
C
      LFRAME = LNOFRAME.AND.
     X         ((NOREPR.EQ.JPREGULAR).OR.(NOREPR.EQ.JPGAUSSIAN).OR.
     X          (NOREPR.EQ.JPREGROT ).OR.(NOREPR.EQ.JPFGGROT  ) )
C
C     Fill area limits (handles case when default 0/0/0/0 given)
C
      IRET = FIXAREA()
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,'INTVECT: area fixup failed',JPQUIET)
        INTVECT = JPROUTINE + 3
        GOTO 900
      ENDIF
C
      AREA(1) = REAL(NOAREA(1))/PPMULT
      AREA(2) = REAL(NOAREA(2))/PPMULT
      AREA(3) = REAL(NOAREA(3))/PPMULT
      AREA(4) = REAL(NOAREA(4))/PPMULT
C
      GRID(1) = REAL(NOGRID(1))/PPMULT
      GRID(2) = REAL(NOGRID(2))/PPMULT
C
      IF( LNOROTA ) THEN
        POLE(1) = REAL(NOROTA(1))/PPMULT
        POLE(2) = REAL(NOROTA(2))/PPMULT
        CALL INTLOG(JP_DEBUG,'INTVECT: Rotate the U & V fields',JPQUIET)
        CALL INTLOG(JP_DEBUG,'INTVECT: South pole lat  ',NOROTA(1))
        CALL INTLOG(JP_DEBUG,'INTVECT: South pole long ',NOROTA(2))
      ELSE
        NOROTA(1) = -9000000
        NOROTA(2) = 0
      ENDIF
C
      IF( .NOT. LSPECUV ) GOTO 500
C
C     Get some scratch memory for the U and V fields
C
      ILENF = NSIZE
      ISIZE = ILENF * 2
      CALL JMEMHAN( 11, ISWORK, NSIZE*2, 1, IRET)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT: memory alloc for scratch memory failed',JPQUIET)
        INTVECT = JPROUTINE + 2
        GOTO 900
      ENDIF
C
C     Unpack U field
C
      NIFORM = 0
      NIPARAM = IN_U
      LWIND = .TRUE.
      LOLDWIND = LWINDSET
      LWINDSET = .TRUE.
C
      IRET = INTUVDH(SWORK,NSIZE,PUFIELD,KASIZE,'D',NIPARAM)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,'INTVECT: Vorticity decoding failed',IRET)
        INTVECT = IRET
        GOTO 900
      ENDIF
      IN_U = ISEC1(6)
C
C     Unpack V field
C
      NIPARAM = IN_V
C
      IRET = INTUVDH(SWORK(1+NSIZE),NSIZE,PVFIELD,KASIZE,'D',NIPARAM)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,'INTVECT: Vorticity decoding failed',IRET)
        INTVECT = IRET
        GOTO 900
      ENDIF
      IN_V = ISEC1(6)
C
      IF( LNOROTA ) GOTO 300
C
C     -----------------------------------------------------------------|
C*    Section 2.   Spectral to grid-point with no rotation
C     -----------------------------------------------------------------|
C
  200 CONTINUE
C
      CALL INTLOG(JP_DEBUG,
     X  'INTVECT: Interpolate U & V fields with no rotation',JPQUIET)
C
      CALL JMEMHAN( 18, ITWORK, ISIZE, 1, IRET)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT: memory alloc for scratch memory failed',JPQUIET)
        INTVECT = JPROUTINE + 2
        GOTO 900
      ENDIF
C
C     Interpolate U field
C
      IRET = INTFAU(SWORK, NSIZE)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT: Prepare to interpolate failed.',JPQUIET)
        INTVECT = JPROUTINE + 2
        GOTO 900
      ENDIF
C
      IRET = INTFBU(SWORK, NSIZE, TWORK, ILENF)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,'INTVECT: Interpolation failed.',JPQUIET)
        INTVECT = JPROUTINE + 2
        GOTO 900
      ENDIF
C
C     Interpolate V field
C
      IRET = INTFAU(SWORK(1+NSIZE),NSIZE)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT: Prepare to interpolate failed.',JPQUIET)
        INTVECT = JPROUTINE + 2
        GOTO 900
      ENDIF
C
      IRET = INTFBU(SWORK(1+NSIZE),NSIZE, TWORK(1+ILENF), ILENF)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,'INTVECT: Interpolation failed.',JPQUIET)
        INTVECT = JPROUTINE + 2
        GOTO 900
      ENDIF
C
      GOTO 700
C
C     -----------------------------------------------------------------|
C*    Section 3.   Spectral to grid-point with rotation
C     -----------------------------------------------------------------|
C
  300 CONTINUE
C
      IF( .NOT.LUSEHIR ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT : Unable to rotate spectral U or V:',JPQUIET)
        INTVECT  = JPROUTINE + 3
        GOTO 900
      ENDIF
C
C     Convert spectral to suitable global reduced gaussian
C
      NTRUNC = NIRESO
      IRET = HSP2GG(NTRUNC,NGAUSS,KPTS,GLATS,ISIZE)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT: problem getting data for reduced grid',NTRUNC)
        INTVECT = JPROUTINE + 4
        GOTO 900
      ENDIF
      NCOUNT = ISIZE
C
C     Dynamically allocate memory for global reduced gaussian grid
C
      CALL JMEMHAN( 18, IRGGRID, (NCOUNT*2), 1, IRET)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT: memory alloc for reduced grid fail',JPQUIET)
        INTVECT = JPROUTINE + 4
        GOTO 900
      ENDIF
C
C     Set flag to show field is a wind component
C
      NUVFLAG = 1
C
C     Create the reduced gaussian grid
C
      HOLDTYP = HOGAUST
      WEST = 0.0
      EAST = 360.0 - (360.0/(NGAUSS*4))
C
C     U component spectral -> reduced gaussian
C
      CALL JAGGGP(SWORK,NTRUNC,GLATS(1),GLATS(NGAUSS*2),WEST,
     X            EAST,NGAUSS,'R',KPTS,RGGRID,NUVFLAG,IRET)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT: spectral to reduced gaussian failed',JPQUIET)
        INTVECT = JPROUTINE + 4
        GOTO 900
      ENDIF
C
      HOGAUST = HOLDTYP
C
C     V component spectral -> reduced gaussian
C
      CALL JAGGGP(SWORK(1+NSIZE),NTRUNC,GLATS(1),GLATS(NGAUSS*2),WEST,
     X            EAST,NGAUSS,'R',KPTS,RGGRID(1+NCOUNT),NUVFLAG,IRET)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT: spectral to reduced gaussian failed',JPQUIET)
        INTVECT = JPROUTINE + 4
        GOTO 900
      ENDIF
C
      HOGAUST = HOLDTYP
C
C     Rotate using 12-point horizontal interpolation
C
C     Dynamically allocate memory for rotated lat/long grid
C
      NLON = 1 + NINT((AREA(JPEAST)  - AREA(JPWEST)) /
     X       GRID(JPWESTEP))                  ! SC
      NLAT = 1 + NINT((AREA(JPNORTH) - AREA(JPSOUTH)) /
     X       GRID(JPNSSTEP))                  ! SC
C
      ILENF = NLON * NLAT
      ISIZE  = ILENF * 2
      CALL JMEMHAN( 17, ITWORK, ISIZE, 1, IRET)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT: memory alloc for lat/long grid fail',JPQUIET)
        INTVECT = JPROUTINE + 6
        GOTO 900
      ENDIF
C
      IRET = HIRLAMW(LO12PT,RGGRID,RGGRID(1+NCOUNT),NCOUNT,NGAUSS,AREA,
     X               POLE,GRID,TWORK,TWORK(1+ILENF),ILENF,NLON,NLAT)
C
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT: HIRLAMW rotation failed',JPQUIET)
        INTVECT = JPROUTINE + 6
        GOTO 900
      ENDIF
C
C     Set the components flag for rotated U and V coefficients
C
      ISEC2(19) = 8
      NOWE = NLON
      NONS = NLAT
C
      GOTO 700
C
C     -----------------------------------------------------------------|
C*    Section 5.   Reduced gaussian to grid-point
C     -----------------------------------------------------------------|
C
  500 CONTINUE
C
      INTVECT =
     X       INTUVGH(PUFIELD,PVFIELD,KASIZE,KUGRIB,KVGRIB,OUTLEN,OUTLEN)
C
      GOTO 900
C
C     -----------------------------------------------------------------|
C*    Section 7.   Pack the fields into GRIB format
C     -----------------------------------------------------------------|
C
  700 CONTINUE
C
C     Reset the input format flag
C
      NIFORM = 1
C
C     If a 'frame' has been specified, build the frame
C
      IF( LFRAME ) THEN
        LOMISSV = LIMISSV
        LIMISSV = .TRUE.
        CALL MKFRAME(NLON,NLAT,TWORK,RMISSGV,NOFRAME)
        CALL MKFRAME(NLON,NLAT,TWORK(1+ILENF),RMISSGV,NOFRAME)
      ENDIF
C
      OUTLENO = OUTLEN
      IRET = INTUVDH(TWORK,ILENF,KUGRIB,OUTLEN,'C',IN_U)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT: Wind component into GRIB encoding fail',IRET)
        INTVECT = JPROUTINE + 7
        GOTO 900
      ENDIF

C
      OUTLEN = OUTLENO
      IRET = INTUVDH(TWORK(1+ILENF),ILENF,KVGRIB,OUTLEN,'C',IN_V)
      IF( IRET.NE.0 ) THEN
        CALL INTLOG(JP_ERROR,
     X    'INTVECT: Wind component into GRIB encoding fail',IRET)
        INTVECT = JPROUTINE + 7
        GOTO 900
      ENDIF
C
      IF( LFRAME ) LIMISSV = LOMISSV
C
C     -----------------------------------------------------------------|
C*    Section 9.   Return
C     -----------------------------------------------------------------|
C
  900 CONTINUE
C
      RETURN
      END
