NCEPLIBS-bufr  11.7.0
 All Data Structures Files Functions Variables Pages
parusr.f
Go to the documentation of this file.
1 C> @file
2 C> @author WOOLLEN @date 1994-01-06
3 
4 C> THIS SUBROUTINE INITATES THE PROCESS TO PARSE OUT MNEMONICS
5 C> (NODES) FROM A USER-SPECIFIED CHARACTER STRING, AND SEPARATES THEM
6 C> INTO STORE AND CONDITION NODES. INFORMATION ABOUT THE STRING
7 C> "PIECES" (I.E., THE MNEMONICS) IS STORED IN ARRAYS IN COMMON BLOCK
8 C> /USRSTR/. CONDITION NODES ARE SORTED IN THE ORDER EXPECTED IN THE
9 C> INTERNAL JUMP/LINK TABLES AND SEVERAL CHECKS ARE PERFORMED ON THE
10 C> NODES.
11 C>
12 C> PROGRAM HISTORY LOG:
13 C> 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
14 C> 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
15 C> "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
16 C> ROUTINE "BORT"; IMPROVED MACHINE
17 C> PORTABILITY
18 C> 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
19 C> INTERDEPENDENCIES
20 C> 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED
21 C> DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
22 C> MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
23 C> TERMINATES ABNORMALLY; CHANGED CALL FROM
24 C> BORT TO BORT2; RESPONDED TO CHANGE IN
25 C> PARUTG (WHICH THIS ROUTINE CALLS) TO NO
26 C> LONGER EXPECT AN ALTERNATE RETURN TO A
27 C> STATEMENT NUMBER IN THIS ROUTINE WHICH
28 C> CALLED BORT (BORT IS NOW CALLED IN PARUTG)
29 C> 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
30 C> 2009-05-07 J. ATOR -- USE LSTJPB INSTEAD OF LSTRPC
31 C>
32 C> USAGE: CALL PARUSR (STR, LUN, I1, IO)
33 C> INPUT ARGUMENT LIST:
34 C> STR - CHARACTER*(*): STRING OF BLANK-SEPARATED MNEMONICS
35 C> LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
36 C> I1 - INTEGER: A NUMBER GREATER THAN OR EQUAL TO THE NUMBER
37 C> OF BLANK-SEPARATED MNEMONICS IN STR
38 C> IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED
39 C> WITH LUN:
40 C> 0 = input file
41 C> 1 = output file
42 C>
43 C> REMARKS:
44 C> THIS ROUTINE CALLS: BORT2 LSTJPB PARSTR PARUTG
45 C> THIS ROUTINE IS CALLED BY: STRING
46 C> Normally not called by any application
47 C> programs.
48 C>
49  SUBROUTINE parusr(STR,LUN,I1,IO)
50 
51 
52 
53  COMMON /usrstr/ nnod,ncon,nods(20),nodc(10),ivls(10),kons(10)
54  COMMON /acmode/ iac
55 
56  CHARACTER*(*) str
57  CHARACTER*128 bort_str1,bort_str2
58  CHARACTER*80 ust
59  CHARACTER*20 utg(30)
60  LOGICAL bump
61 
62  DATA maxusr /30/
63  DATA maxnod /20/
64  DATA maxcon /10/
65 
66 C----------------------------------------------------------------------
67 C----------------------------------------------------------------------
68 
69  ust = str
70  IF(len(str).GT.80) goto 900
71 
72  ncon = 0
73  nnod = 0
74 
75 C PARSE OUT STRING PIECES(S) (UTG's or MNEMONICS)
76 C -----------------------------------------------
77 
78  CALL parstr(ust,utg,maxusr,ntot,' ',.true.)
79 
80  DO n=1,ntot
81 
82 C DETERMINE IF THIS UTG IS A CONDITION NODE OR A STORE NODE
83 C ---------------------------------------------------------
84 
85  CALL parutg(lun,io,utg(n),nod,kon,val)
86  IF(kon.NE.0) THEN
87 c .... it is a condition node
88  ncon = ncon+1
89  IF(ncon.GT.maxcon) goto 901
90  nodc(ncon) = nod
91  kons(ncon) = kon
92  ivls(ncon) = nint(val)
93  ELSE
94 c .... it is a store node
95  nnod = nnod+1
96  IF(nnod.GT.maxnod) goto 902
97  nods(nnod) = nod
98  ENDIF
99  ENDDO
100 
101 C SORT CONDITION NODES IN JUMP/LINK TABLE ORDER
102 C ---------------------------------------------
103 
104  DO i=1,ncon
105  DO j=i+1,ncon
106  IF(nodc(i).GT.nodc(j)) THEN
107  nod = nodc(i)
108  nodc(i) = nodc(j)
109  nodc(j) = nod
110 
111  kon = kons(i)
112  kons(i) = kons(j)
113  kons(j) = kon
114 
115  val = ivls(i)
116  ivls(i) = ivls(j)
117  ivls(j) = val
118  ENDIF
119  ENDDO
120  ENDDO
121 
122 C CHECK ON SPECIAL RULES FOR CONDITIONAL NODES THAT ARE BUMP NODES
123 C ----------------------------------------------------------------
124 
125  bump = .false.
126 
127  DO n=1,ncon
128  IF(kons(n).EQ.5) THEN
129  IF(io.EQ.0) goto 903
130  IF(n.NE.ncon) goto 904
131  bump = .true.
132  ENDIF
133  ENDDO
134 
135 C CHECK STORE NODE COUNT AND ALIGNMENT
136 C ------------------------------------
137 
138  IF(.NOT.bump .AND. nnod.EQ.0) goto 905
139  IF(nnod.GT.i1) goto 906
140 
141  irpc = -1
142  DO i=1,nnod
143  IF(nods(i).GT.0) THEN
144  IF(irpc.LT.0) irpc = lstjpb(nods(i),lun,'RPC')
145  IF(irpc.NE.lstjpb(nods(i),lun,'RPC').AND.iac.EQ.0) goto 907
146  ENDIF
147  ENDDO
148 
149 C EXITS
150 C -----
151 
152  RETURN
153 900 WRITE(bort_str1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS ")')
154  . str
155  WRITE(bort_str2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")')
156  . len(str)
157  CALL bort2(bort_str1,bort_str2)
158 901 WRITE(bort_str1,'("BUFRLIB: PARUSR - THE NUMBER OF CONDITION '//
159  . 'NODES IN INPUT STRING")')
160  WRITE(bort_str2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")')
161  . str,maxcon
162  CALL bort2(bort_str1,bort_str2)
163 902 WRITE(bort_str1,'("BUFRLIB: PARUSR - THE NUMBER OF STORE NODES '//
164  . 'IN INPUT STRING")')
165  WRITE(bort_str2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")')
166  . str,maxnod
167  CALL bort2(bort_str1,bort_str2)
168 903 WRITE(bort_str1,'("BUFRLIB: PARUSR - BUMP NODE (^ IN INPUT '//
169  . 'STRING ",A)') str
170  WRITE(bort_str2,'(18X,"IS SPECIFIED FOR A BUFR FILE OPEN FOR '//
171  . 'INPUT, THE BUFR FILE MUST BE OPEN FOR OUTPUT")')
172  CALL bort2(bort_str1,bort_str2)
173 904 WRITE(bort_str1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") '//
174  . 'CONTAINS")') str
175  WRITE(bort_str2,'(18X,"CONDITIONAL NODES IN ADDITION TO BUMP '//
176  . 'NODE - THE BUMP MUST BE ON THE INNER NODE")')
177  CALL bort2(bort_str1,bort_str2)
178 905 WRITE(bort_str1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS")')
179  . str
180  WRITE(bort_str2,'(18X,"NO STORE NODES")')
181  CALL bort2(bort_str1,bort_str2)
182 906 WRITE(bort_str1,'("BUFRLIB: PARUSR - INPUT STRING (",A,")")') str
183  WRITE(bort_str2,'(18X,"HAS",I5," STORE NODES (MNEMONICS) - THE '//
184  . 'LIMIT {THIRD (INPUT) ARGUMENT} IS",I5)') nnod,i1
185  CALL bort2(bort_str1,bort_str2)
186 907 WRITE(bort_str1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") '//
187  . 'CONTAINS")') str
188  WRITE(bort_str2,'(18X,"STORE NODES (MNEMONICS) THAT ARE IN MORE'//
189  . ' THAN ONE REPLICATION GROUP")')
190  CALL bort2(bort_str1,bort_str2)
191  END
function lstjpb(NODE, LUN, JBTYP)
THIS FUNCTION SEARCHES BACKWARDS, BEGINNING FROM A GIVEN NODE WITHIN THE JUMP/LINK TABLE...
Definition: lstjpb.f:57
subroutine parstr(STR, TAGS, MTAG, NTAG, SEP, LIMIT80)
THIS SUBROUTINE PARSES A STRING CONTAINING ONE OR MORE SUBSTRINGS INTO AN ARRAY OF SUBSTRINGS...
Definition: parstr.f:37
subroutine bort2(STR1, STR2)
This subroutine calls subroutine errwrt() to log two error messages, then calls subroutine bort_exit(...
Definition: bort2.f:22
subroutine parusr(STR, LUN, I1, IO)
THIS SUBROUTINE INITATES THE PROCESS TO PARSE OUT MNEMONICS (NODES) FROM A USER-SPECIFIED CHARACTER S...
Definition: parusr.f:49
subroutine parutg(LUN, IO, UTG, NOD, KON, VAL)
THIS SUBROUTINE PARSES A USER-SPECIFIED TAG (MNEMONIC) (UTG) THAT REPRESENTS A VALUE EITHER BEING DEC...
Definition: parutg.f:120