parusr.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
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> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C>                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C>                           ROUTINE "BORT"; IMPROVED MACHINE
C>                           PORTABILITY
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; RESPONDED TO CHANGE IN
C>                           PARUTG (WHICH THIS ROUTINE CALLS) TO NO
C>                           LONGER EXPECT AN ALTERNATE RETURN TO A
C>                           STATEMENT NUMBER IN THIS ROUTINE WHICH
C>                           CALLED BORT (BORT IS NOW CALLED IN PARUTG)
C> 2007-01-19  J. ATOR    -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
C> 2009-05-07  J. ATOR    -- USE LSTJPB INSTEAD OF LSTRPC
C>
C> USAGE:    CALL PARUSR (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>     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    LSTJPB   PARSTR   PARUTG
C>    THIS ROUTINE IS CALLED BY: STRING
C>                               Normally not called by any application
C>                               programs.
C>
      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) = 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