ungrib/src/ngl/g2/getidx.f

   1 C-----------------------------------------------------------------------
   2       SUBROUTINE GETIDX(LUGB,LUGI,CINDEX,NLEN,NNUM,IRET)
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM: GETIDX         FINDS, READS OR GENERATES A GRIB2 INDEX
   6 C   PRGMMR: GILBERT          ORG: W/NP11     DATE: 2005-03-15
   7 C
   8 C ABSTRACT: FINDS, READS OR GENERATES A GRIB2 INDEX FOR THE GRIB2 FILE
   9 C  ASSOCIATED WITH UNIT LUGB.  IF THE INDEX ALREADY EXISTS, IT IS RETURNED.
  10 C  OTHERWISE, THE INDEX IS (1) READ FROM AN EXISTING INDEXFILE ASSOCIATED WITH
  11 C  UNIT LUGI. OR (2) GENERATED FROM THE GRIB2FILE LUGB ( IF LUGI=0 ).
  12 C  USERS CAN FORCE A REGENERATION OF AN INDEX.  IF LUGI EQUALS LUGB, THE INDEX
  13 C  WILL BE REGENERATED FROM THE DATA IN FILE LUGB.  IF LUGI IS LESS THAN
  14 C  ZERO, THEN THE INDEX IS RE READ FROM INDEX FILE ABS(LUGI).
  15 C
  16 C PROGRAM HISTORY LOG:
  17 C 2005-03-15  GILBERT
  18 C 2009-07-09  VUONG      Fixed bug for checking (LUGB) unit index file
  19 C 2016-03-29  VUONG      Restore original getidx.f from version 1.2.3
  20 C                        Modified GETIDEX to allow to open range of unit file number up to 9999
  21 C                        Added new parameters and new Product Definition Template
  22 C                        numbers: 4.60, 4.61
  23 C
  24 C USAGE:    CALL GETIDX(LUGB,LUGI,CINDEX,NLEN,NNUM,IRET)
  25 C
  26 C   INPUT ARGUMENTS:
  27 C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE.
  28 C                  FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING
  29 C                  THIS ROUTINE.
  30 C     LUGI         INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE.
  31 C                  IF NONZERO, FILE MUST BE OPENED WITH BAOPEN BAOPENR BEFORE
  32 C                  CALLING THIS ROUTINE.
  33 C                  >0 - READ INDEX FROM INDEX FILE LUGI, IF INDEX DOESN"T
  34 C                       ALREADY EXIST.
  35 C                  =0 - TO GET INDEX BUFFER FROM THE GRIB FILE, IF INDEX
  36 C                       DOESN"T ALREADY EXIST.
  37 C                  <0 - FORCE REREAD OF INDEX FROM INDEX FILE ABS(LUGI).
  38 C                  =LUGB - FORCE REGENERATION OF INDEX FROM GRIB2 FILE LUGB.
  39 C
  40 C   OUTPUT ARGUMENTS:
  41 C     CINDEX       CHARACTER*1 POINTER TO A BUFFER THAT CONTAINS INDEX RECORDS.
  42 C     NLEN         INTEGER TOTAL LENGTH OF ALL INDEX RECORDS
  43 C     NNUM         INTEGER NUMBER OF INDEX RECORDS
  44 C     IRET         INTEGER RETURN CODE
  45 C                    0      ALL OK
  46 C                    90     UNIT NUMBER OUT OF RANGE
  47 C                    96     ERROR READING/CREATING INDEX FILE
  48 C
  49 C SUBPROGRAMS CALLED:
  50 C   GETG2I          READ INDEX FILE
  51 C   GETG2IR         READ INDEX BUFFER FROM GRIB FILE
  52 C
  53 C REMARKS:
  54 C        -  Allow file unit numbers in range 0 - 9999
  55 C           the grib index will automatically generate the index file.
  56 C
  57 C ATTRIBUTES:
  58 C   LANGUAGE: FORTRAN 90
  59 C
  60 C$$$
  61
  62       INTEGER,INTENT(IN) :: LUGB,LUGI
  63       INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET
  64       CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CINDEX
  65
  66       INTEGER,PARAMETER :: MAXIDX=10000
  67       INTEGER,PARAMETER :: MSK1=32000,MSK2=4000
  68
  69       TYPE GINDEX
  70          integer :: nlen
  71          integer :: nnum
  72          character(len=1),pointer,dimension(:) :: cbuf
  73       END TYPE GINDEX
  74
  75       TYPE(GINDEX),SAVE :: IDXLIST(10000)
  76
  77       DATA LUX/0/
  78 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  79 C  DECLARE INTERFACES (REQUIRED FOR CBUF POINTER)
  80       INTERFACE
  81          SUBROUTINE GETG2I(LUGI,CBUF,NLEN,NNUM,IRET)
  82             CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
  83             INTEGER,INTENT(IN) :: LUGI
  84             INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET
  85          END SUBROUTINE GETG2I
  86          SUBROUTINE GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,
  87      &                      NMESS,IRET)
  88             CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
  89             INTEGER,INTENT(IN) :: LUGB,MSK1,MSK2,MNUM
  90             INTEGER,INTENT(OUT) :: NLEN,NNUM,NMESS,IRET
  91          END SUBROUTINE GETG2IR
  92       END INTERFACE
  93
  94 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  95 C  DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
  96       LUX=0
  97       IRET=0
  98       IF ( LUGB.LE.0 .OR. LUGB.GT.9999 ) THEN
  99          PRINT*,' '
 100          PRINT *,' FILE UNIT NUMBER OUT OF RANGE'
 101          PRINT *,' USE UNIT NUMBERS IN RANGE: 0 - 9999 '
 102          PRINT*,' '
 103          IRET=90
 104          RETURN
 105       ENDIF
 106       IF (LUGI.EQ.LUGB) THEN      ! Force regeneration of index from GRIB2 File
 107          IF ( ASSOCIATED( IDXLIST(LUGB)%CBUF ) )
 108      &                  DEALLOCATE(IDXLIST(LUGB)%CBUF)
 109          NULLIFY(IDXLIST(LUGB)%CBUF)
 110          IDXLIST(LUGB)%NLEN=0
 111          IDXLIST(LUGB)%NNUM=0
 112          LUX=0
 113       ENDIF
 114       IF (LUGI.LT.0) THEN      ! Force re-read of index from indexfile
 115                                ! associated with unit abs(lugi)
 116          IF ( ASSOCIATED( IDXLIST(LUGB)%CBUF ) )
 117      &                  DEALLOCATE(IDXLIST(LUGB)%CBUF)
 118          NULLIFY(IDXLIST(LUGB)%CBUF)
 119          IDXLIST(LUGB)%NLEN=0
 120          IDXLIST(LUGB)%NNUM=0
 121          LUX=ABS(LUGI)
 122       ENDIF
 123 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 124 C  Check if index already exists in memory
 125       IF ( ASSOCIATED( IDXLIST(LUGB)%CBUF ) ) THEN
 126          CINDEX => IDXLIST(LUGB)%CBUF
 127          NLEN = IDXLIST(LUGB)%NLEN
 128          NNUM = IDXLIST(LUGB)%NNUM
 129          RETURN
 130       ENDIF
 131 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 132       IRGI=0
 133       IF(LUX.GT.0) THEN
 134         CALL GETG2I(LUX,IDXLIST(LUGB)%CBUF,NLEN,NNUM,IRGI)
 135       ELSEIF(LUX.LE.0) THEN
 136         MSKP=0
 137         CALL GETG2IR(LUGB,MSK1,MSK2,MSKP,IDXLIST(LUGB)%CBUF,
 138      &               NLEN,NNUM,NMESS,IRGI)
 139       ENDIF
 140       IF(IRGI.EQ.0) THEN
 141          CINDEX => IDXLIST(LUGB)%CBUF
 142          IDXLIST(LUGB)%NLEN = NLEN
 143          IDXLIST(LUGB)%NNUM = NNUM
 144       ELSE
 145          NLEN = 0
 146          NNUM = 0
 147          PRINT*,' '
 148          PRINT *,' ERROR READING INDEX FILE '
 149          PRINT*,' '
 150          IRET=96
 151          RETURN
 152       ENDIF
 153 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 154 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 155       RETURN
 156       END