1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
|
SUBROUTINE INIT_UVAR ( name, text, title, units, dset, bad,
. implct_defn, uvar,
. at_type, at_id, at_start, at_end,
. natom, txstart, txend, varname,
. its_remote, status )
*
*
* This software was developed by the Thermal Modeling and Analysis
* Project(TMAP) of the National Oceanographic and Atmospheric
* Administration's (NOAA) Pacific Marine Environmental Lab(PMEL),
* hereafter referred to as NOAA/PMEL/TMAP.
*
* Access and use of this software shall impose the following
* obligations and understandings on the user. The user is granted the
* right, without any fee or cost, to use, copy, modify, alter, enhance
* and distribute this software, and any derivative works thereof, and
* its supporting documentation for any purpose whatsoever, provided
* that this entire notice appears in all copies of the software,
* derivative works and supporting documentation. Further, the user
* agrees to credit NOAA/PMEL/TMAP in any publications that result from
* the use of this software or in any product that includes this
* software. The names TMAP, NOAA and/or PMEL, however, may not be used
* in any advertising or publicity to endorse or promote any products
* or commercial entity unless specific written permission is obtained
* from NOAA/PMEL/TMAP. The user also understands that NOAA/PMEL/TMAP
* is not obligated to provide the user with any support, consulting,
* training or assistance of any kind with regard to the use, operation
* and performance of this software nor to provide the user with any
* updates, revisions, new versions or "bug fixes".
*
* THIS SOFTWARE IS PROVIDED BY NOAA/PMEL/TMAP "AS IS" AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL NOAA/PMEL/TMAP BE LIABLE FOR ANY SPECIAL,
* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER
* RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
* CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, ARISING OUT OF OR IN
* CONNECTION WITH THE ACCESS, USE OR PERFORMANCE OF THIS SOFTWARE.
*
*
* Compile a user variable structure into one or more user variables.
* Expression should arrive with the atoms identified in at_type but
* still in inifx order. Since multiple expressions may exist within
* the same text string (text) this routine has txstart and txend
* to indicate the offsets to the particular expression in question
* The incoming expression may contain "grid-changing functions", for example
* yes? LET vfft = TFFT(v) + A + B
* in which "TFFT" replaces the T axis in the course of computing an FFT.
* In such a case a "child variable" is created equivalent to
* yes? LET (013,001) = TFFT(v)
* yes? LET vfft = (013,001) + A + B
* Note that the addition of grid-changing variables and child variables
* was introduced as a series of "hacks" that have made the code needlessly complex.
* Could be cleaned up ... (*sh*)
* revision 0.0 - 2/19/87
* revision 0.1 - 9/22/87 - ferr_uvar_max --> *_prog_limit
* V200: 6/20/89 - re-worked user defined variable logic
* - syntax checking on variable names
* 11/27/89 - major re-write for RPN ordering
* 2/19/90 - corrected error messages
* Unix/RISC port - 7/10/91 - shorter "line too long" text string
* 10/22/92 - added units on uvars
* V402: 7/95 - Added "dset" argument for LET/D=dset var = ...
* V420: 12/95 - initialize uvar_mod_pseudo
* V450: 12/96 - much of the guts of the routine moved to INIT_UVAR_SUB
* Call RPN from within this routine instead of beforehand
* in order to simplify breaking out of grid-changing functions
* 5/97 - create separate child vars for expressions used as args to
* a grid-changing function
* 7/97 - bug fix for case of GCFCN(a,b)
* V491: 2/98 - fix to 5/97 changes: a constant is an expression, too
* V500: 2/99 *sh* - bug fix for GC child var parsing
* GCFCN((a)) generated an error -- paren problem
* V510: 10/99 *sh* - bug fix: if, say, SST[Y=5s:5N:1] is an argument to a GC
* function, this routine must create a child variable so that
* the implicit grid is "owned" by someone.
* 11/99 *sh* - bug fix: if child var occurred in the second (or higher)
* expression in a line the child var name was wrong
* 12/99 *sh* - reverted to this code following temporary commenting out
* of 10/99 fix by Ansley to keep EFs running. Changes to
* EF_GET_ARG_SUBSCRIPTS now permit 10/99 change to work
* 1/00 *sh* - bug fix: parent_uvar was always set to ultimate ancestor
* instead of actual parent. Created gcf stack
* V510: 5/00 *sh* - added "bad" (missing value flag) to arguments
* 1/03 *kob* g77 port - requires use of risc_buff for concats
* V62 2/09 *acm* Pass the original upper/lowercase spelling of user-defined variable
* names to init_uvar_sub; name to be saved in the attribute structure, for
* use when writing out user-defined variables when MODE UPCASE_OUTPUT
* is cancelled.
* *acm* 3/12 6D Ferret (common uses nferdims in tmap_dims.parm)
* V694 *acm* 1214 Fixing ticket 2220: a variablename.attname argument to a function
* needs to be added as a child variable
* V699 *sh* 6/16 bail out code at 5900 needs to clean up child LIST structures
* V720: 4/17 *acm* Add direction-changing functions as a subset of grid-changing ones
* A new grid is defined for these at grid initialization time; it
* will be changed later.
IMPLICIT NONE
include 'tmap_dims.parm'
include 'ferret.parm'
include 'errmsg.parm'
include 'rpn.parm'
include 'xvariables.cmn'
include 'xrisc_buff.cmn'
* calling argument declarations:
LOGICAL implct_defn, its_remote
CHARACTER*(*) name, text, title, units, varname
INTEGER uvar, natom, txstart, txend, status,
. at_type (maxatoms), at_id (maxatoms),
. at_start (maxatoms), at_end (maxatoms), dset
REAL bad
* internal parameter declarations
LOGICAL itsa_gc
INTEGER max_gcf_stack
PARAMETER ( max_gcf_stack = 15 )
* internal variable declarations:
LOGICAL has_children, child, child_remote
INTEGER tlen, iat, paren_level, atoms_lost, uvar_child, gcfstk,
. child_start, child_end, gc_arg_start, istart, iend,
. parent,
. gcf_start(0:max_gcf_stack), gcf_uvar(0:max_gcf_stack)
CHARACTER child_name*16
* initialize
tlen = txend - txstart + 1
has_children = .FALSE.
* find an unused uvar slot for the variable and initialize grid chg fcn stack
DO 100 uvar = 1, max_uvar
IF ( uvar_num_items( uvar ) .EQ. uvar_deleted ) THEN
gcfstk = 0
gcf_start(0) = 0
gcf_uvar (0) = uvar ! assignment never used but what the heck ...
* uvar_num_items( uvar ) = uvar_on_hold
CALL deleted_list_modify(uvar_num_items_head, uvar,
. uvar_on_hold)
GOTO 200
ENDIF
100 CONTINUE
GOTO 5100
* scan the atoms for grid-changing functions. These functions need to
* be compiled each as a separate variable definition.
* These variables will be invisible to the user of Ferret (except when
* using mode diagnostic). They have the special property that their result
* grid cannot necessarily be inferred from the component arguments.
200 paren_level = 0
DO 300 iat = gcf_start(gcfstk)+1, natom
IF ( at_type(iat).EQ.alg_grid_chg_fcn .OR. at_type(iat).EQ.alg_dir_chg_fcn ) THEN
* ... find the variable number for this "child variable"
* Note that for the simple non-nested case of LET v = GCF(arg, arg, ...)
* no child variables are needed - so at the end of this routine we clean
* up left-over "on_hold" uvars
DO 250 uvar_child = 1, max_uvar
IF ( uvar_child .EQ. uvar ) GOTO 250
IF ( uvar_num_items( uvar_child ) .EQ. uvar_deleted ) GOTO 260
250 CONTINUE
GOTO 5900
260 gcfstk = gcfstk + 1 ! new stack level for the child
* uvar_num_items( uvar_child ) = uvar_on_hold
CALL deleted_list_modify(uvar_num_items_head, uvar_child,
. uvar_on_hold)
gcf_uvar (gcfstk) = uvar_child
gcf_start(gcfstk) = iat
paren_level = 0
ELSEIF ( gcfstk .GT. 0
. .AND. at_type(iat).EQ. alg_punctuation ) THEN
IF ( at_id(iat) .EQ. left_paren ) THEN
paren_level = paren_level + 1
ELSEIF ( at_id(iat) .EQ. right_paren ) THEN
paren_level = paren_level - 1
child_end = iat
* ... found the bounds of a grid changing function call ?
IF ( paren_level .EQ. 0 ) GOTO 700
ENDIF
ENDIF
300 CONTINUE
IF ( gcfstk .NE. 0 ) GOTO 5200 ! syntax error
* no (more) child definitions. Go initialize the parent
GOTO 1000
* Grid-changing functions need to know the grids of each of their arguments
* This requires that each argument be "simple" -- expressions like a+b are not
* allowed. In this section, we scan the arguments of the grid-changing
* function and if we find a complex argument or a simple argument that may
* have an implicit grid, we create a separate child
* variable from it
* At this point we know there are no grid-changing functions used in the args.
* In this very simple parsing operation any arg with more than one "atom"
* will generate a separate child variable, including "gcfcn( (A) )"
700 child_start = gcf_start(gcfstk)
gc_arg_start = child_start + 2 ! past first paren
paren_level = 1
DO 750 iat = child_start+2, child_end
IF ( at_type(iat) .NE. alg_punctuation ) GOTO 750
IF ( at_id(iat) .EQ. left_paren ) THEN
paren_level = paren_level + 1
ELSEIF ( at_id(iat) .EQ. right_paren ) THEN
paren_level = paren_level - 1
ENDIF
* ... check for the end of an argument -- comma or final paren
IF ( (at_id(iat).EQ.comma .AND. paren_level.EQ.1)
. .OR. paren_level .EQ. 0 ) THEN
* ...(2/98) treat lone constant like a "complex" argument (an expression)
* ...(10/99)also treat sst[y=5s:5n:1] as a "complex" argument (has impl grid)
istart = at_start (gc_arg_start)
iend = at_end (gc_arg_start)
IF ( at_type(gc_arg_start) .EQ. alg_attrib_val) THEN
* ... make a varname.attname argument into a separate child variable
child_start = gc_arg_start
child_end = iat - 1
GOTO 800
ENDIF
IF ( (at_type(gc_arg_start) .EQ. alg_child_var)
. .OR. ( (iat .EQ. gc_arg_start+1)
. .AND. (at_type(gc_arg_start) .NE. alg_constant)
. .AND. (INDEX(text(istart:iend),'[').EQ.0) ) ) THEN
* ... this argument is "simple" (a single atom)
gc_arg_start = iat + 1 ! look for next
ELSE
* ... make this (complex) argument into a separate child variable
child_start = gc_arg_start
child_end = iat - 1
GOTO 800
ENDIF
ENDIF
750 CONTINUE
* There were no complex arguments in this grid-changing function
* If the entire definition is LET A = GCFCN(args) then no need for child fcns
IF ( gcfstk .EQ. 1
. .AND. .NOT.has_children
. .AND. child_start .LE. 1
. .AND. child_end .EQ. natom ) GOTO 1000
* generate name of child variable -- points to *ancestor*, not parent
800 CALL GCF_CHILD_VAR_NAME( uvar,
. at_start(child_start)-(at_start(1)-1),
. child_name )
itsa_gc = at_type(child_start) .EQ. alg_grid_chg_fcn .OR.
. at_type(child_start) .EQ. alg_dir_chg_fcn
IF ( itsa_gc ) THEN
uvar_child = gcf_uvar(gcfstk)
parent = gcf_uvar(gcfstk-1)
ELSE
DO uvar_child = 1, max_uvar
IF ( uvar_child .EQ. uvar ) GOTO 850
IF ( uvar_num_items( uvar_child ) .EQ. uvar_deleted ) THEN
parent = gcf_uvar(gcfstk)
GOTO 860
ENDIF
850 END DO
GOTO 5900
ENDIF
* initialize the child variable its_remote is set .FALSE. for child variables. (?)
860 child = .TRUE.
child_remote = .FALSE.
CALL INIT_UVAR_SUB (
. child_name,
. text, ' ', ' ', dset, bad,
. child_remote, implct_defn, uvar_child,parent,
. at_type(child_start), at_id(child_start),
. at_start(child_start), at_end(child_start),
. child_end-child_start+1,
. at_start(child_start), at_end(child_end),
. child, child_name, status )
IF ( status .NE. ferr_OK ) GOTO 5900
* ... if the child we just created was a GC then pop the gc stack
IF ( itsa_gc ) gcfstk = gcfstk - 1
* consolidate the parent atom definitions so that the child appears as a
* single atom (a variable) in the definition
atoms_lost = child_end - child_start
at_end(child_start) = at_end(child_end)
at_type(child_start) = alg_child_var ! alg_variable w/ diff. naming
at_id(child_start) = unspecified_int4
DO 900 iat = child_end+1, natom
child_start = child_start + 1
at_start(child_start) = at_start(iat)
at_end(child_start) = at_end(iat)
at_type(child_start) = at_type(iat)
at_id(child_start) = at_id(iat)
900 CONTINUE
natom = natom - atoms_lost
has_children = .TRUE.
GOTO 200 ! back for more children
*============================================================
* initialize the parent user variable, "uvar"
1000 child = .FALSE.
CALL INIT_UVAR_SUB ( name, text, title, units, dset, bad,
. its_remote, implct_defn, uvar, 0,
. at_type, at_id, at_start, at_end,
. natom, txstart, txend, child, varname,
. status )
IF ( status .NE. ferr_OK ) GOTO 5900
* clean up left-over on-hold variables
DO uvar_child = 1, max_uvar
* IF (uvar_num_items(uvar_child) .EQ. uvar_on_hold)
* . uvar_num_items(uvar_child) = uvar_deleted
IF (uvar_num_items(uvar_child) .EQ. uvar_on_hold)
. CALL deleted_list_modify(uvar_num_items_head, uvar_child,
. uvar_deleted )
END DO
* successful completion
status = ferr_ok
RETURN
* error exit
* ... remove any holds left on variable slots
5000 DO uvar = 1, max_uvar
* 5010 IF ( uvar_num_items(uvar) .EQ. uvar_on_hold )
* . uvar_num_items(uvar) = uvar_deleted
IF ( uvar_num_items(uvar) .EQ. uvar_on_hold )
. CALL deleted_list_modify(uvar_num_items_head, uvar,
. uvar_deleted )
END DO
RETURN
5100 CALL ERRMSG( ferr_prog_limit, status,
. 'too many user-defined variables'//pCR//
. 'cancel or redefine some variables', *5000 )
5200 risc_buff = text(txstart:txend)
CALL ERRMSG( ferr_syntax, status,
. 'unclosed parentheses: '//risc_buff, *5000 )
* remove all child variables of the variable being initialized
5900 CALL GCF_CHILD_VAR_NAME( uvar, 0, child_name )
DO 5910 uvar_child = uvar, max_uvar
IF ( uvar_name_code(uvar_child)(7:10)
. .EQ. child_name(7:10) ) THEN
CALL DELETE_USER_VAR(uvar_child, dset)
!* uvar_num_items( uvar_child ) = uvar_deleted
! CALL deleted_list_modify(uvar_num_items_head,
! . uvar_child, uvar_deleted )
!
!* uvar_name_code( uvar_child ) = " "
! CALL string_array_modify(uvar_name_code_head, uvar_child,
! . " ", 1)!
!
! uvar_text ( uvar_child ) = " "
ENDIF
5910 CONTINUE
GOTO 5000
END
|
