<HTML> <BODY BGCOLOR=#ccccdd LINK=#0000aa VLINK=#0000ff ALINK=#ff0000 ><BASE TARGET="bottom_target"><PRE>
<A NAME='PARUSR'><A href='../../html_code/bufr/parusr.f.html#PARUSR' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE PARUSR(STR,LUN,I1,IO) 2,13
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: PARUSR
C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06
C
C ABSTRACT: 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
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: PORTABLE TO ALL PLATFORMS
C
C$$$
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