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 2013-08-02  VUONG      Removed SAVE and initial index buffer
  20 C
  21 C USAGE:    CALL GETIDX(LUGB,LUGI,CINDEX,NLEN,NNUM,IRET)
  22 C
  23 C   INPUT ARGUMENTS:
  24 C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE.
  25 C                  FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING
  26 C                  THIS ROUTINE.
  27 C     LUGI         INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE.
  28 C                  IF NONZERO, FILE MUST BE OPENED WITH BAOPEN BAOPENR BEFORE
  29 C                  CALLING THIS ROUTINE.
  30 C                  >0 - READ INDEX FROM INDEX FILE LUGI, IF INDEX DOESN"T
  31 C                       ALREADY EXIST.
  32 C                  =0 - TO GET INDEX BUFFER FROM THE GRIB FILE, IF INDEX
  33 C                       DOESN"T ALREADY EXIST.
  34 C                  <0 - FORCE REREAD OF INDEX FROM INDEX FILE ABS(LUGI).
  35 C                  =LUGB - FORCE REGENERATION OF INDEX FROM GRIB2 FILE LUGB.
  36 C
  37 C   OUTPUT ARGUMENTS:
  38 C     CINDEX       CHARACTER*1 POINTER TO A BUFFER THAT CONTAINS INDEX RECORDS.
  39 C     NLEN         INTEGER TOTAL LENGTH OF ALL INDEX RECORDS
  40 C     NNUM         INTEGER NUMBER OF INDEX RECORDS
  41 C     IRET         INTEGER RETURN CODE
  42 C                    0      ALL OK
  43 C                    90     UNIT NUMBER OUT OF RANGE
  44 C                    96     ERROR READING/CREATING INDEX FILE
  45 C
  46 C SUBPROGRAMS CALLED:
  47 C   GETG2I          READ INDEX FILE
  48 C   GETG2IR         READ INDEX BUFFER FROM GRIB FILE
  49 C
  50 C REMARKS:
  51 C
  52 C
  53 C ATTRIBUTES:
  54 C   LANGUAGE: FORTRAN 90
  55 C
  56 C$$$
  57
  58       INTEGER,INTENT(IN) :: LUGB,LUGI
  59       INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET
  60       CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CINDEX
  61
  62       INTEGER,PARAMETER :: MAXIDX=100
  63       INTEGER,PARAMETER :: MSK1=32000,MSK2=4000
  64
  65       TYPE GINDEX
  66          integer :: nlen
  67          integer :: nnum
  68          character(len=1),pointer,dimension(:) :: cbuf
  69       END TYPE GINDEX
  70
  71 C     TYPE(GINDEX),SAVE :: IDXLIST(100)
  72       TYPE(GINDEX) :: IDXLIST(100)
  73
  74       DATA LUX/0/
  75 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  76 C  DECLARE INTERFACES (REQUIRED FOR CBUF POINTER)
  77       INTERFACE
  78          SUBROUTINE GETG2I(LUGI,CBUF,NLEN,NNUM,IRET)
  79             CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
  80             INTEGER,INTENT(IN) :: LUGI
  81             INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET
  82          END SUBROUTINE GETG2I
  83          SUBROUTINE GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,
  84      &                      NMESS,IRET)
  85             CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
  86             INTEGER,INTENT(IN) :: LUGB,MSK1,MSK2,MNUM
  87             INTEGER,INTENT(OUT) :: NLEN,NNUM,NMESS,IRET
  88          END SUBROUTINE GETG2IR
  89       END INTERFACE
  90
  91 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  92 C  DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
  93       LUX=0
  94       IRET=0
  95       IF ( LUGB.LE.0 .OR. LUGB.GT.100 ) THEN
  96          IRET=90
  97          RETURN
  98       ENDIF
  99       IF (LUGI.EQ.LUGB) THEN      ! Force regeneration of index from GRIB2 File
 100          IF ( ASSOCIATED( IDXLIST(LUGB)%CBUF ) )
 101      &                  DEALLOCATE(IDXLIST(LUGB)%CBUF)
 102          NULLIFY(IDXLIST(LUGB)%CBUF)
 103          IDXLIST(LUGB)%NLEN=0
 104          IDXLIST(LUGB)%NNUM=0
 105          LUX=0
 106       ENDIF
 107
 108       IF ( ASSOCIATED( IDXLIST(LUGB)%CBUF ) )
 109      &                  DEALLOCATE(IDXLIST(LUGB)%CBUF)
 110
 111       IF (LUGI.LT.0) THEN      ! Force re-read of index from indexfile
 112                                ! associated with unit abs(lugi)
 113          IF ( ASSOCIATED( IDXLIST(LUGB)%CBUF ) )
 114      &                  DEALLOCATE(IDXLIST(LUGB)%CBUF)
 115          NULLIFY(IDXLIST(LUGB)%CBUF)
 116          IDXLIST(LUGB)%NLEN=0
 117          IDXLIST(LUGB)%NNUM=0
 118          LUX=ABS(LUGI)
 119       ENDIF
 120 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 121 C  Check if index already exists in memory
 122       IF ( ASSOCIATED( IDXLIST(LUGB)%CBUF ) ) THEN
 123          CINDEX => IDXLIST(LUGB)%CBUF
 124          NLEN = IDXLIST(LUGB)%NLEN
 125          NNUM = IDXLIST(LUGB)%NNUM
 126          RETURN
 127       ENDIF
 128 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 129       IRGI=0
 130       IF(LUX.GT.0) THEN
 131         CALL GETG2I(LUX,IDXLIST(LUGB)%CBUF,NLEN,NNUM,IRGI)
 132       ELSEIF(LUX.LE.0) THEN
 133         MSKP=0
 134         CALL GETG2IR(LUGB,MSK1,MSK2,MSKP,IDXLIST(LUGB)%CBUF,
 135      &               NLEN,NNUM,NMESS,IRGI)
 136       ENDIF
 137       IF(IRGI.EQ.0) THEN
 138          CINDEX => IDXLIST(LUGB)%CBUF
 139          IDXLIST(LUGB)%NLEN = NLEN
 140          IDXLIST(LUGB)%NNUM = NNUM
 141       ELSE
 142          NLEN = 0
 143          NNUM = 0
 144          IRET=96
 145          RETURN
 146       ENDIF
 147 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 148 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 149       RETURN
 150       END