elemdx.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE DECODES THE SCALE FACTOR, REFERENCE VALUE,
C>   BIT WIDTH AND UNITS (I.E., THE "ELEMENTS") FROM A TABLE B MNEMONIC
C>   DEFINITION CARD THAT WAS PREVIOUSLY READ FROM A USER-SUPPLIED BUFR
C>   DICTIONARY TABLE FILE IN CHARACTER FORMAT BY BUFR ARCHIVE LIBRARY
C>   SUBROUTINE RDUSDX.  THESE DECODED VALUES ARE THEN ADDED TO THE
C>   ALREADY-EXISTING ENTRY FOR THAT MNEMONIC WITHIN THE INTERNAL BUFR
C>   TABLE B ARRAY TABB(*,LUN) IN MODULE TABABD.
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1995-06-28  J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE
C>                           ARRAYS IN ORDER TO HANDLE BIGGER FILES
C> 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C>                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C>                           ROUTINE "BORT"
C> 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C>                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C>                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C>                           BUFR FILES UNDER THE MPI)
C> 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
C>                           DOCUMENTATION; OUTPUTS MORE COMPLETE
C>                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
C>                           ABNORMALLY; CHANGED CALL FROM BORT TO BORT2
C> 2007-01-19  J. ATOR    -- ADDED EXTRA ARGUMENT FOR CALL TO JSTCHR
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C> - 2021-09-30  J. Ator    -- Replace jstchr with Fortran intrinsic
C>                             adjustl
C>
C> USAGE:    CALL ELEMDX (CARD, LUN)
C>   INPUT ARGUMENT LIST:
C>     CARD     - CHARACTER*80: MNEMONIC DEFINITION CARD THAT WAS READ
C>                FROM A USER-SUPPLIED BUFR DICTIONARY TABLE
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS 
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        BORT2    CAPIT    JSTNUM    NEMTAB
C>    THIS ROUTINE IS CALLED BY: RDUSDX   STSEQ
C>                               Normally not called by any application
C>                               programs.
C>
      SUBROUTINE elemdx(CARD,LUN)

      USE moda_tababd

      CHARACTER*128 bort_str1,bort_str2
      CHARACTER*80  card
      CHARACTER*24  unit
      CHARACTER*11  refr,refr_orig
      CHARACTER*8   nemo
      CHARACTER*4   scal,scal_orig
      CHARACTER*3   bitw,bitw_orig
      CHARACTER*1   sign,tab

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

C  CAPTURE THE VARIOUS ELEMENTS CHARACTERISTICS
C  --------------------------------------------

      nemo = card( 3:10)
      scal = card(14:17)
      refr = card(21:31)
      bitw = card(35:37)
      unit = card(41:64)
c  .... Make sure the units are all capitalized
      CALL capit(unit)

C  FIND THE ELEMENT TAG IN TABLE B
C  -------------------------------

C     Note that an entry for this mnemonic should already exist within
C     the internal BUFR Table B array TABB(*,LUN).  We now need to
C     retrieve the positional index for that entry within TABB(*,LUN)
C     so that we can access the entry and then add the scale factor,
C     reference value, bit width, and units to it.

      CALL nemtab(lun,nemo,idsn,tab,iele)
      IF(tab.NE.'B') goto 900

C  LEFT JUSTIFY AND STORE CHARACTERISTICS
C  --------------------------------------

      unit = adjustl(unit)
      IF(unit.EQ.' ') goto 904
      tabb(iele,lun)(71:94) = unit

      scal_orig=scal
      CALL jstnum(scal,sign,iret)
      IF(iret.NE.0) goto 901
      tabb(iele,lun)(95:95) = sign
      tabb(iele,lun)(96:98) = scal

      refr_orig=refr
      CALL jstnum(refr,sign,iret)
      IF(iret.NE.0) goto 902
      tabb(iele,lun)( 99: 99) = sign
      tabb(iele,lun)(100:109) = refr

      bitw_orig=bitw
      CALL jstnum(bitw,sign,iret)
      IF(iret.NE.0  ) goto 903
      IF(sign.EQ.'-') goto 903
      tabb(iele,lun)(110:112) = bitw

C  EXITS
C  -----

      RETURN
900   WRITE(bort_str1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"MNEMONIC ",A," IS NOT A TABLE B ENTRY '//
     . '(UNDEFINED, TAB=",A,")")') nemo,tab
      CALL bort2(bort_str1,bort_str2)
901   WRITE(bort_str1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"PARSED SCALE VALUE (=",A,") IS NOT '//
     . 'NUMERIC")') scal_orig
      CALL bort2(bort_str1,bort_str2)
902   WRITE(bort_str1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"PARSED REFERENCE VALUE (=",A,") IS NOT '//
     . 'NUMERIC")') refr_orig
      CALL bort2(bort_str1,bort_str2)
903   WRITE(bort_str1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"PARSED BIT WIDTH VALUE (=",A,") IS NOT '//
     . 'NUMERIC")') bitw_orig
      CALL bort2(bort_str1,bort_str2)
904   WRITE(bort_str1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"UNITS FIELD IS EMPTY")')
      CALL bort2(bort_str1,bort_str2)
      END