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 GB2GB(
     X  INGRIB,INSIZE,OUTGRIB,OUTSIZE,OUT_EW,OUT_NS,OUTAREA)
C
C---->
C**** GB2GB
C
C     Purpose
C     -------
C
C     Create a subset of an input regular latitude/longitude
C     gridpoint field.
C
C
C     Interface
C     ---------
C
C     IRET = GB2GB(INGRIB,INSIZE,OUTGRIB,OUTSIZE,OUT_EW,OUT_NS,OUTAREA)
C
C     Input
C     -----
C
C     INGRIB  - Input regular latitude/longitude gridpoint field in GRIB
C               format. 
C     INSIZE  - Size in words (integers) of input GRIB product.
C     OUT_EW  - East-west increment of output field (millidegrees).
C     OUT_NS  - North-south increment of output field (millidegrees).
C     OUTAREA - Area boundaries for output field (N/W/S/E millidegrees).
C
C
C     Output
C     ------
C
C     OUTGRIB - Output regular latitude/longitude gridpoint field in GRIB
C               format.
C     OUTSIZE - Size in words (integers) of output GRIB product.
C
C     Returns - length in words (integers) of output GRIB product if OK,
C               negative if error.
C
C
C     Method
C     ------
C
C     Area boundaries for output field are adjusted if necessary to fit
C     the grid (N/W/S/E millidegrees).
C
C
C     Externals
C     ---------
C
C     GRIBEX  - Unpack and pack GRIB products.
C     AREACHK - Fixup input/output field area according to grid
C     INTLOG  - Logs output messages
C     JDEBUG  - Checks whether the debug flag is to be turned on.
C
C
C     Author
C     ------
C
C     J.D.Chambers     ECMWF     March 1999
C
C----<
C
      IMPLICIT NONE
C
#include "jparams.h"
#include "parim.h"
#include "nofld.common"
C
C     Function arguments
C
      INTEGER INGRIB,INSIZE,OUTGRIB,OUTSIZE,OUT_EW,OUT_NS,OUTAREA
      DIMENSION INGRIB(*),OUTGRIB(OUTSIZE),OUTAREA(4)
C
C     Local variables
C
      INTEGER ISEC0,ISEC1,ISEC2,ISEC3,ISEC4
      DIMENSION ISEC0(2),ISEC1(1024),ISEC2(1024),ISEC3(2),ISEC4(512)
      INTEGER ILENP,ILENG,IWORD,IRET,IPOINT
C
      REAL PSEC2,PSEC3,PSEC4
      DIMENSION PSEC2(512),PSEC3(2),PSEC4(1)
C
      INTEGER NVALSI,NVALSO
      REAL ZSEC4I,ZSEC4O
      DIMENSION ZSEC4I(1),ZSEC4O(1)
      POINTER ( NPOINTI, ZSEC4I )
      POINTER ( NPOINTO, ZSEC4O )
C
      INTEGER AREA(4)
      INTEGER INC_EW,INC_NS,N_EW,N_NS,I_EW,I_NS,LOOPO,LOOPI,NEXT
      INTEGER NWEST,NEAST,OWEST,OEAST
      REAL EW,NS,NORTH,WEST,SOUTH,EAST
      LOGICAL LDEBUG, LDUDEW
      CHARACTER*1 HFUNC
C
C     Externals
C
      INTEGER  AREACHK
      EXTERNAL AREACHK
C
C ------------------------------------------------------------------
C     Section 1. Initialise
C ------------------------------------------------------------------
C
  100 CONTINUE
C
      GB2GB = -1
C
      CALL JDEBUG( )
      LDEBUG = ( NDBG.GT.0 )
C
      DO LOOPO = 1, 4
        AREA(LOOPO) = OUTAREA(LOOPO)
      ENDDO
C
C     Unpack input GRIB header.
C
      IRET = 1
      ISEC3(2) = 1E-21
      PSEC3(2) = 1.0E-21
      CALL GRIBEX(ISEC0,ISEC1,ISEC2,PSEC2,ISEC3,PSEC3,ISEC4,
     X            PSEC4,ILENP,INGRIB,INSIZE,IWORD,'J',IRET)
      IF( IRET.GT.0 ) THEN
        IF( LDEBUG )
     X    CALL INTLOG(JP_ERROR,'GB2GB: GRIBEX "J" option error',IRET)
        GOTO 900
      ENDIF
C
C     Ensure that it is a regular latitude/longitude grid.
C
      IF( ISEC2(1).NE.0 ) THEN
        IF( LDEBUG )
     X    CALL INTLOG(JP_ERROR,
     X      'GB2GB: Input not regular lat/long. Type =',ISEC2(1))
        GOTO 900
      ENDIF
C
C ------------------------------------------------------------------
C     Section 2. Check that output grid is a subset of the input grid.
C ------------------------------------------------------------------
C
  200 CONTINUE
C
C     Fixup input/output field area definitions according to grid
C     specification.
C
      EW    = REAL(OUT_EW) / 1000.0
      NS    = REAL(OUT_NS) / 1000.0
      NORTH = REAL(AREA(1)) / 1000.0
      WEST  = REAL(AREA(2)) / 1000.0
      SOUTH = REAL(AREA(3)) / 1000.0
      EAST  = REAL(AREA(4)) / 1000.0
      IRET = AREACHK( EW, NS, NORTH, WEST, SOUTH, EAST )
      IF( IRET.NE.0 ) THEN
        IF( LDEBUG )
     X    CALL INTLOG(JP_ERROR,'GB2GB: AREACHK failed:',IRET)
        GOTO 900
      ENDIF
C
      OUT_EW = NINT(EW * 1000.0)
      OUT_NS = NINT(NS * 1000.0)
      AREA(1) = NINT(NORTH * 1000.0)
      AREA(2) = NINT(WEST  * 1000.0)
      AREA(3) = NINT(SOUTH * 1000.0)
      AREA(4) = NINT(EAST  * 1000.0)
C
C     Check (sub)area limits
C
C     North and south ..
C
      IF( (AREA(1).GT.ISEC2(4)) .OR.
     X    (AREA(3).LT.ISEC2(7)) ) THEN
        IF( LDEBUG ) THEN
          CALL INTLOG(JP_ERROR,
     X      'GB2GB: North/south outside input GRIB area',JPQUIET)
          CALL INTLOG(JP_ERROR,'GB2GB: Requested north  = ',OUTAREA(1))
          CALL INTLOG(JP_ERROR,'GB2GB: Requested south  = ',OUTAREA(3))
          CALL INTLOG(JP_ERROR,'GB2GB: Input GRIB north = ',ISEC2(4))
          CALL INTLOG(JP_ERROR,'GB2GB: Input GRIB south = ',ISEC2(7))
          GOTO 900
        ENDIF
      ENDIF
C
C     East and west ..
C
      NWEST = AREA(2)
      NEAST = AREA(4)
      OWEST = ISEC2(5)
      OEAST = ISEC2(8)
C
      LDUDEW = 
     X  ((NWEST.LT.0).AND.(OWEST.LT.0).AND.(NWEST.LT.OWEST)).OR.
     X  ((NWEST.GT.0).AND.(OWEST.GT.0).AND.(NWEST.LT.OWEST)).OR.
     X  ((NWEST.LT.0).AND.(OWEST.GT.0).AND.(NWEST.LT.(OWEST-36000))).OR.
     X  ((NWEST.GT.0).AND.(OWEST.LT.0).AND.(NWEST.LT.(OWEST+36000))).OR.
     X  ((NEAST.LT.0).AND.(OEAST.LT.0).AND.(NEAST.GT.OEAST)).OR.
     X  ((NEAST.GT.0).AND.(OEAST.GT.0).AND.(NEAST.GT.OEAST)).OR.
     X  ((NEAST.LT.0).AND.(OEAST.GT.0).AND.(NEAST.GT.(OEAST-36000))).OR.
     X  ((NEAST.GT.0).AND.(OEAST.LT.0).AND.(NEAST.GT.(OEAST+36000)))
C
      IF( LDUDEW ) THEN
        IF( LDEBUG ) THEN
          CALL INTLOG(JP_ERROR,
     X      'GB2GB: East/west outside input GRIB area',JPQUIET)
          CALL INTLOG(JP_ERROR,'GB2GB: Requested west  = ',OUTAREA(2))
          CALL INTLOG(JP_ERROR,'GB2GB: Requested east  = ',OUTAREA(4))
          CALL INTLOG(JP_ERROR,'GB2GB: Input GRIB west = ',ISEC2(5))
          CALL INTLOG(JP_ERROR,'GB2GB: Input GRIB east = ',ISEC2(8))
        ENDIF
        GOTO 900
      ENDIF
C
      IF( NWEST.LT.0 ) NWEST = NWEST + 360000
      IF( NEAST.LT.0 ) NEAST = NEAST + 360000
      IF( NEAST.LT.NWEST ) NEAST = NEAST + 360000
      IF( OWEST.LT.0 ) OWEST = OWEST + 360000
      IF( OEAST.LT.0 ) OEAST = OEAST + 360000
      IF( OEAST.LT.OWEST ) OEAST = OEAST + 360000
C
C     Check increments
C
      INC_EW = OUT_EW / ISEC2(9)
      IF( (INC_EW*ISEC2(9)).NE.OUT_EW ) THEN
        IF( LDEBUG ) THEN
          CALL INTLOG(JP_ERROR,
     X      'GB2GB: East-west step not multiple of input grid',JPQUIET)
          CALL INTLOG(JP_ERROR,'GB2GB: Requested step  = ',OUT_EW)
          CALL INTLOG(JP_ERROR,'GB2GB: Input GRIB step = ',ISEC2(9))
        ENDIF
        GOTO 900
      ENDIF
C
      INC_NS = OUT_NS / ISEC2(10)
      IF( (INC_NS*ISEC2(10)).NE.OUT_NS ) THEN
        IF( LDEBUG ) THEN
          CALL INTLOG(JP_ERROR,
     X     'GB2GB: North-south step not multiple of input grid',JPQUIET)
          CALL INTLOG(JP_ERROR,'GB2GB: Requested step  = ',OUT_NS)
          CALL INTLOG(JP_ERROR,'GB2GB: Input GRIB step = ',ISEC2(10))
        ENDIF
        GOTO 900
      ENDIF
C
C ------------------------------------------------------------------
C     Section 3. Generate new grid.
C ------------------------------------------------------------------
C
  300 CONTINUE
C
C     Get memory for input GRIB values.
C
      NVALSI = ISEC2(2)*ISEC2(3)
      CALL JMEMHAN(3,NPOINTI,NVALSI,1,IRET)
      IF( IRET.NE.0 ) THEN
        IF( LDEBUG )
     X    CALL INTLOG(JP_ERROR,'GB2GB: JMEMHAN failed for input',IRET)
        GOTO 900
      ENDIF
C
C     Get memory for output GRIB values.
C
      N_EW = ( (NEAST - NWEST) / OUT_EW ) + 1
      N_NS = ( (AREA(1) - AREA(3)) / OUT_NS ) + 1
      NVALSO = N_EW * N_NS
      CALL JMEMHAN(4,NPOINTO,NVALSO,1,IRET)
      IF( IRET.NE.0 ) THEN
        IF( LDEBUG )
     X    CALL INTLOG(JP_ERROR,'GB2GB: JMEMHAN failed for output',IRET)
        GOTO 900
      ENDIF
C
C     Unpack input GRIB values.
C
      IRET = 1
      CALL GRIBEX(ISEC0,ISEC1,ISEC2,PSEC2,ISEC3,PSEC3,ISEC4,
     X            ZSEC4I,NVALSI,INGRIB,INSIZE,IWORD,'D',IRET)
      IF( IRET.GT.0 ) THEN
        IF( LDEBUG )
     X    CALL INTLOG(JP_ERROR,'GB2GB: GRIBEX "D" option error',IRET)
        GOTO 900
      ENDIF
C
C     Select points for new grid.
C
      I_EW = (NWEST / ISEC2(9) ) + 1
      I_NS = ((90000-AREA(1)) / ISEC2(10) ) + 1
C
      NEXT = 1
      DO LOOPO = I_NS, (I_NS-1+N_NS*INC_NS),INC_NS
        DO LOOPI = I_EW, (I_EW-1+N_EW*INC_EW),INC_EW
          IPOINT = MOD(ISEC2(2)+LOOPI-1,ISEC2(2))+1
          ZSEC4O(NEXT) = ZSEC4I((LOOPO-1)*ISEC2(2)+IPOINT)
          NEXT = NEXT + 1
        ENDDO
      ENDDO
C
C ------------------------------------------------------------------
C     Section 4. Pack new grid into GRIB.
C ------------------------------------------------------------------
C
  400 CONTINUE
C
      ISEC2(2)  = N_EW
      ISEC2(3)  = N_NS
      ISEC2(4)  = OUTAREA(1)
      ISEC2(5)  = OUTAREA(2)
      ISEC2(7)  = OUTAREA(3)
      ISEC2(8)  = OUTAREA(4)
      ISEC2(9)  = OUT_EW
      ISEC2(10) = OUT_NS
C
      ISEC4(1)  = N_NS * N_EW
      IF( (NOACC.GT.0).AND.(NOACC.LT.30) ) ISEC4(2) = NOACC
C
C     PACKING specified can be second-order, simple or archive value
C
      IF( NOHFUNC.EQ.'K' ) THEN
        HFUNC = 'K'
        ISEC4(4)  = 64
        ISEC4(6)  = 16
        ISEC4(9)  = 32
        ISEC4(10) = 16
        ISEC4(12) = 8
        ISEC4(13) = 4
        ISEC4(14) = 0
        ISEC4(15) = -1
      ELSE IF( NOHFUNC.EQ.'S' ) THEN
        HFUNC = 'C'
        ISEC4(4)  = 0
        ISEC4(6)  = 0
      ELSE IF( NOHFUNC.EQ.'A' ) THEN
        IF( ISEC4(4).EQ.64 ) THEN
          HFUNC = 'K'
        ELSE
          HFUNC = 'C'
        ENDIF
      ENDIF
C
      IRET = 1
      CALL GRIBEX(ISEC0,ISEC1,ISEC2,PSEC2,ISEC3,PSEC3,ISEC4,
     X            ZSEC4O,NVALSO,OUTGRIB,OUTSIZE,IWORD,HFUNC,IRET)
      IF( IRET.GT.0 ) THEN
        IF( LDEBUG )
     X    CALL INTLOG(JP_ERROR,'GB2GB: GRIBEX "C" option error',IRET)
        GOTO 900
      ENDIF
      GB2GB = IWORD
C
C ------------------------------------------------------------------
C     Section 9. Return.
C ------------------------------------------------------------------
C
  900 CONTINUE
C
      RETURN
      END
