parusr.f

Go to the documentation of this file.

C> @file
C> @brief Initate the process to parse out mnemonics from a character string.
C>
C> @author Woollen @date 1994-01-06
 
C> Initate the process to parse out mnemonics from a character string.
C>
C> This subroutine initates the process to parse out mnemonics
C> (nodes) from a user-specified character string, and separates them
C> into store and condition nodes. Information about the string
C> "pieces" (i.e., the mnemonics) is stored in arrays in common block
C> /usrstr/. Condition nodes are sorted in the order expected in the
C> internal jump/link tables and several checks are performed on the
C> nodes.
C>
C> @param[in] STR - character*(*): string of blank-separated mnemonics.
C> @param[in] LUN - integer: File ID.
C> @param[in] I1 - integer: a number greater than or equal to the number of
C> blank-separated mnemonics in STR.
C> @param[in] IO - integer: status indicator for BUFR file associated with LUN:
C> - 0 input file
C> - 1 output file
C>
C> @author Woollen @date 1994-01-06
      SUBROUTINE parusr(STR,LUN,I1,IO)
 
      COMMON /usrstr/ nnod,ncon,nods(20),nodc(10),ivls(10),kons(10)
      COMMON /acmode/ iac
 
      CHARACTER*(*) STR
      CHARACTER*128 BORT_STR1,BORT_STR2
      CHARACTER*80  UST
      CHARACTER*20  UTG(30)
      LOGICAL       BUMP
 
      DATA maxusr /30/
      DATA maxnod /20/
      DATA maxcon /10/
 
C----------------------------------------------------------------------
C----------------------------------------------------------------------
 
      ust  = str
      IF(len(str).GT.80) GOTO 900
 
      ncon = 0
      nnod = 0
 
C  PARSE OUT STRING PIECES(S) (UTG's or MNEMONICS)
C  -----------------------------------------------
 
      CALL parstr(ust,utg,maxusr,ntot,' ',.true.)
 
      DO n=1,ntot
 
C  DETERMINE IF THIS UTG IS A CONDITION NODE OR A STORE NODE
C  ---------------------------------------------------------
 
      CALL parutg(lun,io,utg(n),nod,kon,val)
      IF(kon.NE.0) THEN
c  .... it is a condition node
         ncon = ncon+1
         IF(ncon.GT.maxcon) GOTO 901
         nodc(ncon) = nod
         kons(ncon) = kon
         ivls(ncon) = nint(val)
      ELSE
c  .... it is a store node
         nnod = nnod+1
         IF(nnod.GT.maxnod) GOTO 902
         nods(nnod) = nod
      ENDIF
      ENDDO
 
C  SORT CONDITION NODES IN JUMP/LINK TABLE ORDER
C  ---------------------------------------------
 
      DO i=1,ncon
      DO j=i+1,ncon
      IF(nodc(i).GT.nodc(j)) THEN
         nod     = nodc(i)
         nodc(i) = nodc(j)
         nodc(j) = nod
 
         kon     = kons(i)
         kons(i) = kons(j)
         kons(j) = kon
 
         val     = ivls(i)
         ivls(i) = ivls(j)
         ivls(j) = nint(val)
      ENDIF
      ENDDO
      ENDDO
 
C  CHECK ON SPECIAL RULES FOR CONDITIONAL NODES THAT ARE BUMP NODES
C  ----------------------------------------------------------------
 
      bump = .false.
 
      DO n=1,ncon
      IF(kons(n).EQ.5) THEN
         IF(io.EQ.0)   GOTO 903
         IF(n.NE.ncon) GOTO 904
         bump = .true.
      ENDIF
      ENDDO
 
C  CHECK STORE NODE COUNT AND ALIGNMENT
C  ------------------------------------
 
      IF(.NOT.bump .AND. nnod.EQ.0) GOTO 905
      IF(nnod.GT.i1)                GOTO 906
 
      irpc = -1
      DO i=1,nnod
      IF(nods(i).GT.0) THEN
         IF(irpc.LT.0) irpc = lstjpb(nods(i),lun,'RPC')
         IF(irpc.NE.lstjpb(nods(i),lun,'RPC').AND.iac.EQ.0) GOTO 907
      ENDIF
      ENDDO
 
C  EXITS
C  -----
 
      RETURN
900   WRITE(bort_str1,'("BUFRLIB: PARUSR - 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: PARUSR - THE NUMBER OF CONDITION '//
     . 'NODES IN INPUT STRING")')
      WRITE(bort_str2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")')
     . str,maxcon
      CALL bort2(bort_str1,bort_str2)
902   WRITE(bort_str1,'("BUFRLIB: PARUSR - THE NUMBER OF STORE NODES '//
     . 'IN INPUT STRING")')
       WRITE(bort_str2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")')
     . str,maxnod
      CALL bort2(bort_str1,bort_str2)
903   WRITE(bort_str1,'("BUFRLIB: PARUSR - BUMP NODE (^ IN INPUT '//
     . 'STRING ",A)') str
      WRITE(bort_str2,'(18X,"IS SPECIFIED FOR A BUFR FILE OPEN FOR '//
     . 'INPUT, THE BUFR FILE MUST BE OPEN FOR OUTPUT")')
      CALL bort2(bort_str1,bort_str2)
904   WRITE(bort_str1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") '//
     . 'CONTAINS")') str
      WRITE(bort_str2,'(18X,"CONDITIONAL NODES IN ADDITION TO BUMP '//
     . 'NODE - THE BUMP MUST BE ON THE INNER NODE")')
      CALL bort2(bort_str1,bort_str2)
905   WRITE(bort_str1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS")')
     . str
      WRITE(bort_str2,'(18X,"NO STORE NODES")')
      CALL bort2(bort_str1,bort_str2)
906   WRITE(bort_str1,'("BUFRLIB: PARUSR - INPUT STRING (",A,")")') str
      WRITE(bort_str2,'(18X,"HAS",I5," STORE NODES (MNEMONICS) - THE '//
     . 'LIMIT {THIRD (INPUT) ARGUMENT} IS",I5)') nnod,i1
      CALL bort2(bort_str1,bort_str2)
907   WRITE(bort_str1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") '//
     . 'CONTAINS")') str
      WRITE(bort_str2,'(18X,"STORE NODES (MNEMONICS) THAT ARE IN MORE'//
     . ' THAN ONE REPLICATION GROUP")')
      CALL bort2(bort_str1,bort_str2)
      END