string.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE CHECKS TO SEE IF A USER-SPECIFIED CHARACTER
C>   STRING IS IN THE STRING CACHE (ARRAYS IN COMMON BLOCKS /STCACH/ AND
C>   /STORDS/).  IF IT IS NOT IN THE CACHE, IT MUST CALL THE BUFR
C>   ARCHIVE LIBRARY PARSING SUBROUTINE PARUSR TO PERFORM THE TASK OF
C>   SEPARATING AND CHECKING THE INDIVIDUAL "PIECES" (I.E., MNEMONICS)
C>   SO THAT IT CAN THEN BE ADDED TO THE CACHE.  IF IT IS ALREADY IN THE
C>   CACHE, THEN THIS EXTRA WORK DOES NOT NEED TO BE PERFORMED.  THE
C>   MNEMONIC STRING CACHE IS A PERFORMANCE ENHANCING DEVICE WHICH SAVES
C>   TIME WHEN THE SAME MNEMONIC STRINGS ARE ENCOUNTERED IN A USER
C>   PROGRAM, OVER AND OVER AGAIN (THE TYPICAL SCENARIO).
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1998-04-02  J. WOOLLEN -- MODIFIED TO ENLARGE THE CACHE FROM 50
C>                           ELEMENTS TO 1000, MAXIMUM; OPTIMIZATION OF
C>                           THE CACHE SEARCH ALGORITHM IN SUPPORT OF A
C>                           BIGGER CACHE
C> 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C>                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C>                           ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS
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  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
C>                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
C>                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
C>                           TERMINATES ABNORMALLY; CHANGED CALL FROM
C>                           BORT TO BORT2
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL STRING (STR, LUN, I1, IO)
C>   INPUT ARGUMENT LIST:
C>     STR      - CHARACTER*(*): STRING OF BLANK-SEPARATED MNEMONICS
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>
C>   OUTPUT ARGUMENT LIST:
C>     I1       - INTEGER: A NUMBER GREATER THAN OR EQUAL TO THE NUMBER
C>                OF BLANK-SEPARATED MNEMONICS IN STR
C>     IO       - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED
C>                WITH LUN:
C>                       0 = input file
C>                       1 = output file
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        BORT2    PARUSR
C>    THIS ROUTINE IS CALLED BY: UFBEVN   UFBGET   UFBIN3   UFBINT
C>                               UFBOVR   UFBREP   UFBSTP   UFBTAB
C>                               UFBTAM
C>                               Normally not called by any application
C>                               programs.
C>
      SUBROUTINE string(STR,LUN,I1,IO)
 
      USE modv_mxs
      USE moda_msgcwd
 
      parameter(jcons=52)
 
      COMMON /stcach/ mstr,nstr,lstr,lux(mxs,2),usr(mxs),icon(jcons,mxs)
      COMMON /usrstr/ jcon(jcons)
      COMMON /stords/ iord(mxs),iorx(mxs)
 
      CHARACTER*(*) STR
      CHARACTER*128 BORT_STR1,BORT_STR2
      CHARACTER*80  USR,UST
 
C----------------------------------------------------------------------
C----------------------------------------------------------------------
 
      nxt = 0
      ust = str
      ind = inode(lun)
      IF(len(str).GT.80) GOTO 900
 
C     Note that LSTR, MSTR and NSTR were initialized via a prior call to
C     subroutine STRCLN, which itself was called by subroutine MAKESTAB.
 
C  SEE IF STRING IS IN THE CACHE
C  -----------------------------
 
      DO n=1,nstr
      IF(lux(iord(n),2).EQ.ind) THEN
         iorx(nxt+1) = iord(n)
         nxt = nxt+1
      ENDIF
      ENDDO
      DO n=1,nxt
      IF(ust.EQ.usr(iorx(n)))goto1
      ENDDO
      goto2
 
C  IF IT IS IN THE CACHE, COPY PARAMETERS FROM THE CACHE
C  -----------------------------------------------------
 
1     DO j=1,jcons
      jcon(j) = icon(j,iorx(n))
      ENDDO
      GOTO 100
 
C  IF IT IS NOT IN THE CACHE, PARSE IT AND PUT IT THERE
C  ----------------------------------------------------
 
2     CALL parusr(str,lun,i1,io)
      lstr = max(mod(lstr+1,mstr+1),1)
      nstr = min(nstr+1,mstr)
c  .... File
      lux(lstr,1) = lun
c  .... Table A entry
      lux(lstr,2) = ind
      usr(lstr) = str
      DO j=1,jcons
      icon(j,lstr) = jcon(j)
      ENDDO
 
C  REARRANGE THE CACHE ORDER AFTER AN UPDATE
C  -----------------------------------------
 
      DO n=nstr,2,-1
      iord(n) = iord(n-1)
      ENDDO
      iord(1) = lstr
 
100   IF(jcon(1).GT.i1) GOTO 901
 
C  EXITS
C  -----
 
      RETURN
900   WRITE(bort_str1,'("BUFRLIB: STRING - INPUT STRING (",A,") HAS")')
     . str
      WRITE(bort_str2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")')
     .  len(str)
      CALL bort2(bort_str1,bort_str2)
901   WRITE(bort_str1,'("BUFRLIB: STRING - INPUT STRING (",A,")")') str
      WRITE(bort_str2,'(18X,"HAS",I5," STORE NODES (MNEMONICS) - THE '//
     . 'LIMIT (THIRD INPUT ARGUMENT) IS",I5)') jcon(1),i1
      CALL bort2(bort_str1,bort_str2)
      END