	SUBROUTINE IS_ALGEBRA( memory, *, *, isp_base, 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. 
*
*
* evaluate an algebraic evpression component by component on the 
* interpretation stack.  When component variables are required request them
* by return to the top of the stack processor in "request" mode (RETURN 1).

* programmer - steve hankin
* NOAA/PMEL, Seattle, WA - Tropical Modeling and Analysis Program
* written for VAX computer under VMS operating system
*
* revision 0.0 - 2/12/87
* revision 0.1 - 6/ 3/87 - corrected 'alg_stk_err' in "LIST 1"
* revision 0.2 - 7/28/87 - changed method of constant evaluation to be like
*			   vars and pseudo-vars in order to avoid stack errors
*			   from constants left on stack when this subr. exits
* revision 0.2a- 8/29/87 - context stack bug for norm trans of constant
* V200:  6/20/89 - 4D symmetric version, numerous changes
*	11/29/89 - include constants and pseudo-variables on context merges
* V312:  5/94 - array "memory" as a calling argument
* V420:  9/95 - deallocate dynamic grid (if any) at cleanup time
* V450:  1/97 - process alg_child_var and alg_grid_chg_fcn
*        7/97 - generate child var name using GCF_PARENT_UVAR
* V491   3/98 - sgi benchmarking uncovered bug in psuedo_variable processing - 
*               no valid "name" was being set up   *kob/sh*
*        4/98 - pass default context (lo_cx) to MERGE_CONTEXT *jc*
* V500: 12/98 *sh* - add cat_const_var (like "{1,3,5}")
*	 1/99 *sh* - add cat_string -- temporarily do not allow A="string"
*	 3/99 *sh* - bug fix in context passing to GC args
*		default cx must contain grid before call to
*		GCF_IMPOSE_ARG_LIM_DFLTS  - so it can check if arg
*		axes match result for (say) RESHAPE
*		This requires a "2-pass" approach ("ugly hack", below).
*	3/99 *sh* ==> NOT IMPLEMENTER (see "3/99" below)
*		call TRANSFER_CONTEXT(big_cx, lo_cx) at end of
*		EXPLICIT_UVAR, too, since changes to handling unspecified
*		limits (see COMPLETE_MISSING_LIMITS)
* V510: 8/99 *sh* - added SAMPLE*. Logic in this routine is because the
*		2nd arg to SAMPLE* controls the request for the 1st --
*		here we detect that, interchange the ordering, and
*		call IS_SAMPLE for arg 1 (Note: would have been much simpler
*		if arg order was reversed, but the function already existed
*	10/99 *sh* repair of bug introduced by 3/99 change for RESHABE, above
*		see "ugly hack" in code
*	1/00 *sh* error check bug corrected for GC functions (esp. RESHAPE) 
*	1/00 *sh* naming bug corrected for nested GC functions
*	2/00 *sh* bug in check for SAMPLE finctions -- use nitem not "3"
*	3/00 *sh* bug in ERRMSG call at 5900 - extra comma in args
* V510: 5/00 *sh* - set bad flag on user variables
*	5/00 *sh* - bug fix: ifcn not init'ed in time for MERGE_CONTEXT(big_cx)
* V530: 8/00 *sh* - added support for string arrays
*	12/00 *sh* bug fix: constants as in LET a = 5 were not deleted -- they
*		accumulated and used up mvars -- err522_too_many_vars.jnl
* V533: 7/01 *sh* - added support for functions returning different data types
*		  - alg_no_op removed to allow string IF-THEN-ELSE exprns
* v552: 4/03 *acm*  Increase length of variable names to 128 characters
*                   (variables are up to 128, so **name** needs extra space
*                   i.e. for a transformation specifier)
* v554: 1/04 *acm* Counter variables for REPEAT/RANGE=/NAME=
* V600 8/05 *acm* - Add variable type attrib_val for definitions of the form
*                   varname.attname
* v664 9/10 *acm* Check variables for NaN and replace (unless the bad-value IS NaN
* V671 7/11  *acm* Ticket 1868 IFV - masking expressions with ifValid, treating 
*		   zero as valid. 
*       *acm* 3/12 6D Ferret (common uses nferdims in tmap_dims.parm)

	include 'tmap_dims.parm'
#include "netcdf.inc"
	include	'ferret.parm'
	include	'errmsg.parm'
	include	'interp_stack.parm'
	include	'grid_chg_fcns.parm'
	include	'xcontext.cmn'
	include	'xvariables.cmn'
	include	'xprog_state.cmn'
        include 'xcontrol.cmn'
        include 'xalgebra.cmn'

* calling argument declarations:
	INTEGER	isp_base, status
	REAL	memory( mem_blk_size, max_mem_blks )
* normal return is for error conditions
* exit #1 is to request another grid ( stack has been pushed )
* exit #2 is to signal completion of the activity at this stack level

* internal variable declarations:
	LOGICAL	EXPLICIT_UVAR, ITSA_GCVAR, NC_GET_ATTRIB, 
     .          its_gc, its_sample, start_sampling, got_it, coordvar,
     .          reset_ss, do_err
	INTEGER KNOWN_GRID, TM_LENSTR1, GCF_PARENT_UVAR, GCF_PARENT_CHAR,
     .		GCF_FIND_FCN, GCF_ARG_EVAL_ORDER, GET_VAR_GRID,
     .		MGRID_SIZE, STR_SAME, hi_mr, hi_cx, lo_cx, big_cx,
     .		dflt_cx, start, end, saved_grid, ifcn, size,
     .		dset, lo_isp, uvar, item, itype, idim,
     .		nitem, new_mr, len_name, idig, csp1, cat, cvar, 
     .          varid, attlen, attype, maxlen, attoutflag,
     .          ndims, nvars, ngatts, recdim, ivar, vartype, 
     .          nvdims, vdims(8), nvatts, nv, iatt, all_outflag, dot,
     .          attid, slen
        REAL    counter_const, val

	CHARACTER TM_FMT*150, name*150, attname*128, aname*128, buff*10

*        ... interpretation stack setup at the time this is called ...
*	stack level		stack contents
*	isp+1	<--	level of next activity ( component to get )
*	 isp	<--	... ( current stack level )
*	isp-1		...
*	isp-2	<--	...	components of this uvar on stack
*	isp-n		...
*	lo_isp	<--	level controlling evaluation of uvar

* --- end of introductory code ---

* test to see if first time called - designate stack activity as algebra
	IF ( is_act(isp) .EQ. isact_request ) THEN
	   lo_isp = isp
	   is_phase( lo_isp ) = 0
	   is_act  ( lo_isp ) = isact_algebra
	ELSE
	   isp = isp + 1			! point to component just got
	   lo_isp = is_obj( isp )
	   hi_cx  = is_cx( isp )
	ENDIF

* convenience values
	lo_cx  = is_cx( lo_isp )
	big_cx = is_big_cx( lo_isp )
	uvar   = is_uvar( lo_isp )
	nitem  = uvar_num_items( uvar )
	dset   = cx_data_set( lo_cx )

* is it a grid-changing variable?
	its_gc = ITSA_GCVAR(uvar)
	IF ( its_gc ) THEN
	   start = uvar_item_start( nitem, uvar )  ! nitem has the fcn itself
	   end   = uvar_item_end  ( nitem, uvar )
	   ifcn = GCF_FIND_FCN( uvar_text(uvar)(start:end) )
	ENDIF

* create, initialize or merge overall context for the algebraic expression
	IF ( is_phase(lo_isp) .EQ. 0 ) THEN
	   cx_grid( lo_cx ) = KNOWN_GRID( dset ,cat_user_var, uvar )
	   IF ( mode_diagnostic )
     .			CALL DIAGNOSTIC_OUT( 'eval   ', lo_cx, point_to_cx )
	   CALL STACK_PTR_UP( cx_stack_ptr, max_context, status )
	   IF ( status .NE. ferr_ok ) RETURN
	   big_cx = cx_stack_ptr
	   CALL INIT_EMPTY_CONTEXT( big_cx)  ! moved from below 8/00 *sh*
	   is_big_cx( lo_isp ) = big_cx
	   is_sum   ( lo_isp ) = isalg_transfer
!	ELSEIF ( cx_category( hi_cx ) .EQ. cat_constant
!     .	   .OR. ( cx_category(hi_cx) .EQ. cat_pseudo_var
!     .		  .AND. .NOT.cx_unstand_grid(hi_cx)      )  ) THEN
!	   GOTO 100		! can't construct a context from these

* 1/97 - need a somewhat separate path through the merging of contexts when
*	dealing with grid changing variables. For non-grid-changing vars
*	we may have "LIST A", inwhich case the merged context needs to look
*	just like "A". For grid-changing variables this can never occur, since
*	they are always of the form GCFUNC(arg1, arg2, ...), but it is not
*	safe to begin the merging with TRANSFER_CONTEXT because the first
*	arg may be designated not to contribute all of its axes to the merged
*	result 
	ELSEIF ( its_gc ) THEN
	   IF ( is_sum(lo_isp) .EQ. isalg_transfer ) THEN
	      CALL MERGIFY_CX( lo_cx, uvar, big_cx, status )
!	      cx_type(big_cx) = ptype_float   ! TEMPORARY - UNTIL STRNG FCNS
	      is_sum( lo_isp ) = isalg_merge_1
	   ELSEIF ( is_sum(lo_isp) .EQ. isalg_merge_1 ) THEN
* ... this allows us to distinguish between single component and
*	multi-component expressions. "LIST A" should document "A", not "E315"
	      is_sum( lo_isp ) = isalg_merge_n
	   ENDIF
	   item = GCF_ARG_EVAL_ORDER( ifcn, is_phase(lo_isp) )
	   itype = uvar_item_type ( item, uvar )
	   start = uvar_item_start( item, uvar )
	   end   = uvar_item_end  ( item, uvar )
	   CALL MERGE_CONTEXT(	its_gc, item, lo_cx, big_cx, hi_cx,
     .				uvar_text(uvar)(start:end), status )
	   IF ( status .NE. ferr_ok ) RETURN

* pre grid-changing code - 1st arg treated differently from others
	ELSEIF ( is_sum(lo_isp) .EQ. isalg_transfer ) THEN
	   CALL TRANSFER_CONTEXT( hi_cx, big_cx )
	   is_sum( lo_isp ) = isalg_merge_1
	ELSE
	   IF (  is_sum(lo_isp) .EQ. isalg_merge_1 ) THEN
	      CALL MERGIFY_CX( lo_cx, uvar, big_cx, status )
	      IF ( status .NE. ferr_ok ) GOTO 5000
!	      cx_type(big_cx) = ptype_float   ! only GC vars allow strings (??)
	      is_sum( lo_isp ) = isalg_merge_n
	   ENDIF
	   item = is_phase(lo_isp)		! points into uvar_text
	   itype = uvar_item_type ( item, uvar )
	   start = uvar_item_start( item, uvar )
	   end   = uvar_item_end  ( item, uvar )
	   CALL MERGE_CONTEXT( its_gc, item, lo_cx, big_cx, hi_cx,
     .				uvar_text(uvar)(start:end), status )
	   IF ( status .NE. ferr_ok ) RETURN
	ENDIF

* is it a SAMPLE* function? (8/99)
	IF ( its_gc ) THEN
	   its_sample = ifcn .GE. p_samplei
     .		.AND.   ifcn .LE. p_samplen
	ELSE
	   its_sample = .FALSE.
	ENDIF
	start_sampling = .FALSE.

* ****** (continue) LOOP through expression ***********************************
* process the next item in the expression from the uvar buffer
 100	is_phase(lo_isp) = is_phase(lo_isp) + 1
	IF ( its_gc ) THEN
	   item = GCF_ARG_EVAL_ORDER( ifcn, is_phase(lo_isp) )
	ELSE
	    item = is_phase(lo_isp)		! points into uvar_text
	ENDIF
	IF ( its_sample ) THEN		! kludge for SAMPLE*
	   start_sampling = item .EQ. 1
	ENDIF  
	IF ( item .GT. nitem ) GOTO 1000
	itype = uvar_item_type ( item, uvar )
	start = uvar_item_start( item, uvar )
	end   = uvar_item_end  ( item, uvar )
	IF     ( itype .EQ. alg_constant   ) THEN
	   GOTO 200
	ELSEIF ( itype .EQ. alg_child_var   ) THEN
	   GOTO 300
	ELSEIF ( itype .EQ. alg_variable   ) THEN
	   GOTO 305
	ELSEIF ( itype .EQ. alg_pseudo_var ) THEN
	   GOTO 400
	ELSEIF ( itype .EQ. alg_function
     .	    .OR. itype .EQ. alg_operator
     .	    .OR. itype .EQ. alg_log_struct
     .	    .OR. itype .EQ. alg_log_vstruct   ) THEN
	   GOTO 500
	ELSEIF ( itype .EQ. alg_grid_chg_fcn ) THEN
	   GOTO 600
	ELSEIF ( itype .EQ. alg_const_var ) THEN
	   GOTO 700
	ELSEIF ( itype .EQ. alg_attrib_val ) THEN
	   GOTO 750
        ELSEIF ( itype .EQ. alg_string ) THEN
	   GOTO 800
	ELSEIF ( itype .EQ. alg_if_marker
     .	    .OR. itype .EQ. alg_then_marker ) THEN
	   GOTO 100
	ELSEIF ( itype .EQ. alg_counter_var ) THEN
	   GOTO 210
	ELSE
	   STOP 'unknown algebraic category'
	ENDIF

* constant - with possible transformations (eg. integrated --> 1[Z=1:100@DIN])
* ... allocate a context buffer 
 200	CALL STACK_PTR_UP( cx_stack_ptr, max_context, status )
	IF ( status .NE. ferr_ok ) RETURN
	hi_cx = cx_stack_ptr
	CALL CONSTANT_CONTEXT   ( uvar_text(uvar)(start:end),
     .				  lo_cx,
     .				  hi_cx,
     .				  status )
	IF ( status .NE. ferr_ok ) RETURN
* ... request this constant on the interpretation stack ( via RETURN 1 )
	CALL PUSH_INTERP_STACK( isp, status )
	IF ( status .NE. ferr_ok ) RETURN
	is_cx ( isp ) = hi_cx
	is_obj( isp ) = lo_isp	! claimed by this level
	RETURN 1
        
* counter (REPEAT/RANGE=/NAME=)
* ... allocate a context buffer, dummy constant value which is replaced
* ... later when the counter is evaluated.
 210	CALL STACK_PTR_UP( cx_stack_ptr, max_context, status )
	IF ( status .NE. ferr_ok ) RETURN
	hi_cx = cx_stack_ptr
        
* as in cs_command 
        
        CALL find_var_name (dset, uvar_text(uvar)(start:end), cat, cvar)
        csp1 = csp_cvar(cvar)
	counter_const = cs_phase( csp1 ) - cs_delta( csp1 )
        name = TM_FMT(counter_const, idig, 150, len_name)
	CALL CONSTANT_CONTEXT   ( name,
     .				  lo_cx,
     .				  hi_cx,
     .				  status )
	IF ( status .NE. ferr_ok ) RETURN
* ... request this constant on the interpretation stack ( via RETURN 1 )
	CALL PUSH_INTERP_STACK( isp, status )
	IF ( status .NE. ferr_ok ) RETURN
	is_cx ( isp ) = hi_cx
	is_obj( isp ) = lo_isp	! claimed by this level
	RETURN 1

* child variable: treat it just like a regular variable except that 
* its name is not found in the text. Instead generate its name from
* its position and its parent variable
* example: for the definition	LET A = 5 * GCFUNC(b,c)
*    the string "GCFUNC(b,c)" is processed as a child variable
 300	CALL GCF_CHILD_VAR_NAME( GCF_PARENT_UVAR(uvar),
     .				 GCF_PARENT_CHAR(uvar,start), name )
	len_name = TM_LENSTR1(name)
	GOTO 310

* variable: parse name, update full expression context and evaluate
* ... allocate a context buffer for components
 305	name = uvar_text(uvar)(start:end)
	len_name = end - start + 1
 310	CALL STACK_PTR_UP( cx_stack_ptr, max_context, status )
	IF ( status .NE. ferr_ok ) RETURN
	hi_cx = cx_stack_ptr
	IF ( .NOT. its_gc ) THEN
	   CALL GET_VAR_CONTEXT (  name(:len_name),
     .				   lo_cx,
     .				   hi_cx,
     .				   status )
	   IF ( status .NE. ferr_ok ) RETURN

	ELSE
* ... for GC variables the default context may get modified before using it
*     to get an argument (e.g. for a fcn equivalent to x=@sbx:5 we'd have
*     LIST/I=5:10 XSBX5(b) requiring I=3:12 of argument "b".
*     BUT: for RESHAPE the grid must already be known to guide this process 
* ... ugly hack: temporarily insert grid into lo_cx
	   saved_grid = cx_grid(lo_cx)
	   cx_grid(lo_cx) = GET_VAR_GRID(name(:len_name),
     .				         lo_cx,
     .				         hi_cx,
     .				         status )
	   IF ( status .NE. ferr_ok ) RETURN
	   CALL STACK_PTR_UP( cx_stack_ptr, max_context, status )
	   IF ( status .NE. ferr_ok ) RETURN
	   dflt_cx = cx_stack_ptr
	   CALL GCF_IMPOSE_ARG_LIM_DFLTS( name(:len_name), item,
     .					  lo_cx, dflt_cx, uvar, status )
	   IF (status .NE. ferr_ok) RETURN
	   cx_grid(lo_cx) = saved_grid		! restore HACK
	   CALL GET_VAR_CONTEXT (  name(:len_name),
     .				dflt_cx,
     .				hi_cx,
     .				status )
	   IF ( status .NE. ferr_ok ) RETURN
	   cx_stack_ptr = cx_stack_ptr - 1	! release dflt_cx
	   IF (cx_has_impl_grid(hi_cx)) THEN	! 10/99
	     CALL DEALLO_DYN_GRID(cx_grid(hi_cx))
	   ENDIF
	ENDIF
* ... request this variable on the interpretation stack ( via RETURN 1 )
	CALL PUSH_INTERP_STACK( isp, status )
	IF ( status .NE. ferr_ok ) RETURN
	is_cx ( isp ) = hi_cx
	is_obj( isp ) = lo_isp	! claimed by this level
	IF ( cx_category(hi_cx) .EQ. cat_user_var ) THEN
* ... special action if this component variable is user-defined (uvar)
	   is_uvar( isp ) = cx_variable( hi_cx )
	ENDIF
	IF ( start_sampling ) GOTO 900
	RETURN 1

* pseudo-variable: parse mods, update full expression context and evaluate
* ... allocate a context buffer for components
 400	CALL STACK_PTR_UP( cx_stack_ptr, max_context, status )
	IF ( status .NE. ferr_ok ) RETURN
	hi_cx = cx_stack_ptr
	CALL PSEUDO_VAR_CONTEXT ( uvar_text(uvar)(start:end),
     .				  lo_cx,
     .				  hi_cx,
     .				  idim,
     .				  status )
	IF ( status .NE. ferr_ok ) RETURN

	IF (its_gc ) THEN	! see explanation under "variable' (stmt 310)
* ... ugly hack: temporarily insert grid into lo_cx
	   saved_grid = cx_grid(lo_cx)
	   cx_grid(lo_cx) = cx_grid(hi_cx)
	   CALL STACK_PTR_UP( cx_stack_ptr, max_context, status )
	   IF ( status .NE. ferr_ok ) RETURN
	   dflt_cx = cx_stack_ptr
* use uvar_text as name to pass to gcf_impose...*kob* 3/98
	   CALL GCF_IMPOSE_ARG_LIM_DFLTS( uvar_text(uvar)(start:end), item,
     .					  lo_cx, dflt_cx, uvar, status )
	   IF (status .NE. ferr_ok) RETURN
	   cx_grid(lo_cx) = saved_grid		! restore HACK
	   CALL PSEUDO_VAR_CONTEXT ( uvar_text(uvar)(start:end),
     .				  dflt_cx,
     .				  hi_cx,
     .				  idim,
     .				  status )
	   IF ( status .NE. ferr_ok ) RETURN
	   cx_stack_ptr = cx_stack_ptr - 1	! release dflt_cx
	ENDIF

	IF ( cx_lo_ss(hi_cx,idim) .EQ. unspecified_int4 )  CALL ERRMSG
     .		(ferr_dim_underspec, status,uvar_text(uvar)(start:end), *5000)
! temp diag
	IF ( cx_grid(hi_cx) .EQ. unspecified_int4 ) CALL ERRMSG
     .			( ferr_internal, status, 'isalg_ps', *5000 )
* ... request this variable on the interpretation stack ( via RETURN 1 )
	CALL PUSH_INTERP_STACK( isp, status )
	IF ( status .NE. ferr_ok ) RETURN
	is_cx ( isp ) = hi_cx
	is_obj( isp ) = lo_isp	! claimed by this level
	IF ( start_sampling ) GOTO 900
	RETURN 1

* function logic structure or operator:
* ...compute new value replacing component(s) (if any) on stack
* ...and changing variable protections appropriately
* ...also pop the space they used on the context stack
 500	CALL IS_DO_OP( memory, itype, uvar_text(uvar)(start:end),
     .		       lo_isp, uvar_ifv(uvar), status )
	IF ( status .NE. ferr_ok ) RETURN
	GOTO 100

* grid-changing function 
* ...(internal or external GC function)
* ...in addition to the manipulations of IS_DO_OP above, this procedure
* ...has the additional flexibility that the result grid need not be
* ...inferrable from the input component grids

* 10/98 *jc*
* CALL ADD_RDC_XFORM is a test to see if we can get the right
* context onto the context which will be used for the result
 600    CALL ADD_RDC_XFORM(is_big_cx(lo_isp), status)
	CALL IS_DO_GC_FCN( memory, uvar, uvar_text(uvar)(start:end),
     .		       lo_isp, status )
	IF ( status .NE. ferr_ok ) RETURN
	GOTO 100

* "constant variable" (fixed array like "{1,3,5}")
* ... get the context here, then RETURN 1 to evaluate
 700	CALL STACK_PTR_UP( cx_stack_ptr, max_context, status )
	IF ( status .NE. ferr_ok ) RETURN
	hi_cx = cx_stack_ptr
	CALL CONST_VAR_CONTEXT ( uvar_text(uvar)(start:end),
     .				 uvar,
     .				 item,
     .				 lo_cx,
     .				 hi_cx,
     .				 status )
	IF ( status .NE. ferr_ok ) RETURN
* ... request this variable on the interpretation stack ( via RETURN 1 )
	CALL PUSH_INTERP_STACK( isp, status )
	IF ( status .NE. ferr_ok ) RETURN
	is_cx ( isp ) = hi_cx
	is_obj( isp ) = lo_isp	! claimed by this level
	IF ( cx_category(hi_cx) .EQ. cat_const_var ) THEN
* ... special action if this component variable is user-defined (uvar)
	   is_uvar( isp ) = cx_variable( hi_cx )
	ENDIF
	IF ( start_sampling ) GOTO 900
	RETURN 1

* "attrib_val" a string or float value or array of strings or floats.
* ... get the context here, then RETURN 1 to evaluate
 750	CALL STACK_PTR_UP( cx_stack_ptr, max_context, status )

	IF ( status .NE. ferr_ok ) RETURN
	hi_cx = cx_stack_ptr

        
* set these to unspecified.  If they get set in GET_VAR_CONTEXT, 
* then do not set them to 1:attlen below.

 	cx_lo_ss(hi_cx, x_dim) = unspecified_int4
 	cx_hi_ss(hi_cx, x_dim) = unspecified_int4

	CALL GET_VAR_CONTEXT (  uvar_text(uvar),
     .				lo_cx,
     .				hi_cx,
     .				status )
	IF ( status .NE. ferr_ok ) RETURN

* Flag to set the limits. They were not set by GET_VAR_CONTEXT, so use the
* attribute size

        reset_ss = (cx_lo_ss(hi_cx, x_dim) .EQ. unspecified_int4  .OR.
     .              cx_hi_ss(hi_cx, x_dim) .EQ. unspecified_int4 ) 

        dset = cx_data_set(hi_cx)

! See if this is a user variable and set dataset number accordingly

        dot = INDEX(uvar_text(uvar),'.')
        IF (dot .GT. 0) name = uvar_text(uvar)(1:dot-1)
        CALL FIND_VAR_NAME(pdset_irrelevant, name, cat, ivar)
        IF (  ivar .NE. munknown_var_name .AND.
     .        cat .EQ. cat_user_var) dset = -1

        IF (dset .NE. unspecified_int4 .AND. 
     .      dset .NE. pdset_irrelevant) THEN

* do_err: issue error message if attrib does not exist on varname.attname
           do_err = .TRUE.
           CALL  BREAK_VARATTNAME (  uvar_text(uvar), dset, 
     .                            name, attname, varid, do_err, status )

* Is the *attr name* a pseudo-name for a variable: attnames, dimnames,
*  natts, type, ...

           IF (varid .GT. 0) THEN
              CALL CD_GET_VAR_INFO (dset, varid, name, vartype,
     .                nvdims, vdims, nvatts, coordvar, all_outflag, 
     .                status)

* attribute names
              IF (STR_SAME(attname, 'attnames') .EQ. 0 ) THEN
                 cx_type(hi_cx) = ptype_string
                 IF (reset_ss) THEN
                    cx_lo_ss(hi_cx, x_dim) = 1
                    cx_hi_ss(hi_cx, x_dim) = nvatts
                 ELSE
                    cx_lo_ss(hi_cx, x_dim) = MAX(1, cx_lo_ss(hi_cx, x_dim))
                    cx_hi_ss(hi_cx, x_dim) = MIN(nvatts, cx_hi_ss(hi_cx, x_dim))
                 ENDIF

* dimension names
              ELSE IF (STR_SAME(attname, 'dimnames') .EQ. 0 ) THEN 
                 cx_type(hi_cx) = ptype_string
                 IF (reset_ss) THEN
                    cx_lo_ss(hi_cx, x_dim) = 1
                    cx_hi_ss(hi_cx, x_dim) = nvdims
                 ELSE
                    cx_lo_ss(hi_cx, x_dim) = MAX(1, cx_lo_ss(hi_cx, x_dim))
                    cx_hi_ss(hi_cx, x_dim) = MIN(nvdims, cx_hi_ss(hi_cx, x_dim))
                 ENDIF
 
* # of dimensions for variable 
              ELSE IF (STR_SAME(attname, 'ndims') .EQ. 0 ) THEN
                 cx_type(hi_cx) = ptype_float
                 cx_lo_ss(hi_cx, x_dim) = 1
                 cx_hi_ss(hi_cx, x_dim) = 1

*  variable types
              ELSE IF (STR_SAME(attname, 'nctype') .EQ. 0 ) THEN
                 cx_type(hi_cx) = ptype_float
                 cx_lo_ss(hi_cx, x_dim) = 1
                 cx_hi_ss(hi_cx, x_dim) = 1

* # of attributes
               ELSE IF (STR_SAME(attname, 'nattrs') .EQ. 0 ) THEN
                cx_type(hi_cx) = ptype_float
                 cx_lo_ss(hi_cx, x_dim) = 1
                 cx_hi_ss(hi_cx, x_dim) = 1

               ELSE
           
* General attribute.
* Get attribute type and length
        
                  CALL CD_GET_VAR_ATT_ID (dset, varid, attname, attid,
     .               status)
                  IF (attid .GT. 0) CALL CD_GET_VAR_ATT_INFO (dset, varid,  
     .              attid, aname, attype, attlen, attoutflag, status )

                  IF (status .NE. ferr_ok) THEN
                     RETURN ! ?? error message
                  ENDIF

                  IF (attype .EQ. NCCHAR) THEN
                     cx_type(hi_cx) = ptype_string
	          ELSE
	             cx_type(hi_cx) = ptype_float
	          ENDIF

* If the attribute we are asking for is the bad-data flag, set 
* cx_bad_data to something else, so that the value will be displayed.

                  IF (STR_SAME (attname, 'missing_value') .EQ. 0 .OR.
     .               STR_SAME (attname, '_FillValue') .EQ. 0) THEN
                     maxlen = 1
                     got_it = NC_GET_ATTRIB ( dset, varid, attname, 
     .                                .TRUE., name, maxlen, attlen, 
     .                                attoutflag, buff, val)
                     IF (got_it) cx_bad_data(hi_cx) = val/2. + 1.
                  ENDIF

                  IF (attype .EQ. NCCHAR) THEN
                     cx_lo_ss(hi_cx, x_dim) = 1
                     cx_hi_ss(hi_cx, x_dim) = 1
                  ELSE
 
* If they were not set by the var context, set the X axis limits equal 
* to the length of the array. 

                    IF (reset_ss) THEN
                        cx_lo_ss(hi_cx, x_dim) = 1
                        cx_hi_ss(hi_cx, x_dim) = attlen
                    ELSE
                       cx_lo_ss(hi_cx, x_dim) = MAX(1, cx_lo_ss(hi_cx, x_dim))
                       cx_hi_ss(hi_cx, x_dim) = MIN(attlen, cx_hi_ss(hi_cx, x_dim))
                    ENDIF
                 ENDIF

               ENDIF  ! general attribute

* If the varname is ., referring to the dataset itself, then the varid = 0. These are
* dataset attributes: varnames, attnames, dimnames, ndims, nvars, ...

           ELSE 
              IF (varid .EQ. 0) THEN
                 CALL CD_GET_DS_INFO (dset, ndims, nvars, ngatts, 
     .               recdim, status)
     
* Count number of non-coordinate variables.
                 nv = 0
                 DO 760 ivar = 1, nvars
                    CALL CD_GET_VAR_INFO (dset, ivar, name, vartype,
     .                  nvdims, vdims, nvatts, coordvar, all_outflag, 
     .                  status)
                    IF (.NOT. coordvar) nv = nv + 1
 760             CONTINUE

                 IF (STR_SAME(attname, 'varnames') .EQ. 0 ) THEN
                    cx_type(hi_cx) = ptype_string
                    IF (reset_ss) THEN
                       cx_lo_ss(hi_cx, x_dim) = 1
                       cx_hi_ss(hi_cx, x_dim) = nv
                    ELSE
                       cx_lo_ss(hi_cx, x_dim) = MAX(1, cx_lo_ss(hi_cx, x_dim))
                       cx_hi_ss(hi_cx, x_dim) = MIN(nv, cx_hi_ss(hi_cx, x_dim))
                    ENDIF

* Global attributes
                 ELSE IF (STR_SAME(attname, 'attnames') .EQ. 0 ) THEN
                    cx_type(hi_cx) = ptype_string
                    IF (reset_ss) THEN
                       cx_lo_ss(hi_cx, x_dim) = 1
                       cx_hi_ss(hi_cx, x_dim) = ngatts
                    ELSE
                       cx_lo_ss(hi_cx, x_dim) = MAX(1, cx_lo_ss(hi_cx, x_dim))
                       cx_hi_ss(hi_cx, x_dim) = MIN(ngatts, cx_hi_ss(hi_cx, x_dim))
                    ENDIF
                    
* # of dimensions
                 ELSE IF (STR_SAME(attname, 'ndims') .EQ. 0 ) THEN
                    cx_type(hi_cx) = ptype_float
                    cx_lo_ss(hi_cx, x_dim) = 1
                    cx_hi_ss(hi_cx, x_dim) = 1
   
* dimension names
                 ELSE IF (STR_SAME(attname, 'dimnames') .EQ. 0 ) THEN
                    cx_type(hi_cx) = ptype_string


* Count number of coordinate variables. (file may list more dimensions than
* coordinates, e.g. a dimension for the grid definition, which is not a coord.)
                    nv = 0
                    DO 770 ivar = 1, nvars
                       CALL CD_GET_VAR_INFO (dset, ivar, name, vartype,
     .                     nvdims, vdims, nvatts, coordvar, all_outflag, 
     .                     status)
                       IF (coordvar) nv = nv + 1
 770                CONTINUE

                    IF (reset_ss) THEN
                       cx_lo_ss(hi_cx, x_dim) = 1
                       cx_hi_ss(hi_cx, x_dim) = nv
                    ELSE
                       cx_lo_ss(hi_cx, x_dim) = MAX(1, cx_lo_ss(hi_cx, x_dim))
                       cx_hi_ss(hi_cx, x_dim) = MIN(ndims, cx_hi_ss(hi_cx, x_dim))
                    ENDIF

* # variables 
                 ELSE IF (STR_SAME(attname, 'nvars') .EQ. 0 ) THEN
                    cx_type(hi_cx) = ptype_float
                    cx_lo_ss(hi_cx, x_dim) = 1
                    cx_hi_ss(hi_cx, x_dim) = 1

* # of global attributes
                 ELSE IF (STR_SAME(attname, 'nattrs') .EQ. 0 ) THEN
                    cx_type(hi_cx) = ptype_float
                    cx_lo_ss(hi_cx, x_dim) = 1
                    cx_hi_ss(hi_cx, x_dim) = 1

* Is the reference to a global attribute? If so get its type and length

                 ELSE
                    CALL CD_GET_VAR_ID (dset, '.', varid, status)
                    CALL CD_GET_DS_INFO (dset, ndims, nvars, ngatts, 
     .               recdim, status)

* If the attribute name is in quotes remove them. Perhaps the user
* is looking for a global file attribute named the same as one of our
* pseudo- attribute names 
* (Logic for case-sensitive searching will go here...)

                    slen = TM_LENSTR1(attname)
                    IF (attname(1:1) .EQ. "'" .AND. 
     .                   attname(slen:slen) .EQ. "'" ) THEN
                       attname = attname(2:slen-1)
                       attname(slen-1:slen) = ""
                    ENDIF


                    DO 790 iatt = 1, ngatts
                       CALL CD_GET_VAR_ATT_NAME (dset, varid, iatt, name, 
     .                    status)
                       IF (STR_SAME(name, attname) .EQ. 0) THEN

                          CALL CD_GET_VAR_ATT_INFO (dset, varid, iatt, 
     .                        name, attype, attlen, attoutflag, status )

                          cx_type(hi_cx) = ptype_float
                          cx_lo_ss(hi_cx, x_dim) = 1
                          cx_hi_ss(hi_cx, x_dim) = attlen

                          IF (attype .EQ. NCCHAR) THEN
                             cx_type(hi_cx) = ptype_string
                             cx_hi_ss(hi_cx, x_dim) = 1
                          ENDIF

                       ENDIF

 790                CONTINUE

                 ENDIF
              ENDIF
           ENDIF

        ELSE
           CALL TRANSFER_CONTEXT (lo_cx, hi_cx)
        ENDIF

* ... request this variable on the interpretation stack ( via RETURN 1 )
	CALL PUSH_INTERP_STACK( isp, status )
	IF ( status .NE. ferr_ok ) RETURN
	is_cx ( isp ) = hi_cx
	is_obj( isp ) = lo_isp	! claimed by this level
	IF ( cx_category(hi_cx) .EQ. cat_user_var ) THEN
* ... special action if this component variable is user-defined (uvar)
	   is_uvar( isp ) = cx_variable( hi_cx )
	ENDIF
	IF ( start_sampling ) GOTO 900
	RETURN 1

* "string" in quotes in variable definition
* ... get the context here, then RETURN 1 to evaluate
 800	CALL STACK_PTR_UP( cx_stack_ptr, max_context, status )
	IF ( status .NE. ferr_ok ) RETURN
	hi_cx = cx_stack_ptr
	CALL STRING_CONTEXT (	uvar,
     .				item,
     .				lo_cx,
     .				hi_cx,
     .				status )
	IF ( status .NE. ferr_ok ) RETURN
* ... request this variable on the interpretation stack ( via RETURN 1 )
	CALL PUSH_INTERP_STACK( isp, status )
	IF ( status .NE. ferr_ok ) RETURN
	is_cx ( isp ) = hi_cx
	is_obj( isp ) = lo_isp	! claimed by this level
	IF ( cx_category(hi_cx) .EQ. cat_string ) THEN
* ... special action if this component variable is user-defined (uvar)
	   is_uvar( isp ) = cx_variable( hi_cx )
	ENDIF
	RETURN 1

* "SAMPLEI" (and its family)
* at this point the list of indices has been evaluated and is on the isp stack
* (at lo_isp+1). Setup "sampling" activity on the stack, using that list to
* guide obtaining the other arg
 900	CALL SETUP_SAMPLE( memory, is_cx(lo_isp+1), is_mr(lo_isp+1),
     .			   ifcn, big_cx, status )
	IF ( status .NE. ferr_ok ) GOTO 5000
* ... setup to grab first chunk of sampling data
	CALL IS_SAMPLE( memory, *910, *5900, status ) !	RETURN 2 means all done
	GOTO 5900
 910	RETURN 1


* DONE - clean up
 1000	hi_cx = is_cx( isp )
	hi_mr = is_mr( isp )
	is_mr( lo_isp ) = hi_mr
	isp = isp - 1
	IF ( isp .NE. lo_isp ) 
     .	   CALL ERRMSG( ferr_syntax, status, 'RPN', *5000 )

* Deallocate dynamic grid if one is associated with this result
* This will (I think) only happen if a single component (no IS_DO_OP call)
* result with a dynamic grid is requested
* (This will not actually dismiss the grid -- it should always merely decrement
*  the use count)
	IF ( cx_has_impl_grid(hi_cx) ) THEN
	   CALL DEALLO_DYN_GRID(cx_grid(hi_cx))
	   cx_has_impl_grid(hi_cx) = .FALSE.
	ENDIF

* check for incomplete merged context
* this is complicated in order to have implicit user-defn'd vars like
* "LIST TEMP" get cataloged under "TEMP"
* whereas "LIST TEMP/10" gets cataloged under the implied user-defn'd var name
* and whereas the explicit "DEFINE A=TEMP" gets cataloged under "A".
* Use the isp level to determine if it's implicit - implicit always at base lev
* MERGIFY_CX "claims" a context under the user-defn'd name.
	IF ( is_sum(lo_isp) .EQ. isalg_transfer ) THEN
* ... expression entirely of unmodified pseudo-vars and constants
	   CALL TRANSFER_CONTEXT( hi_cx, big_cx )
	   IF ( cx_category(big_cx) .EQ. cat_temp_var
     .	   .OR. EXPLICIT_UVAR(uvar) ) THEN
* ... expr. like "LIST I+J" or "LIST A" after "DEFINE VAR A=I"
	      CALL MERGIFY_CX( lo_cx, uvar, big_cx, status )
	      IF ( status .NE. ferr_ok ) GOTO 5000
	   ENDIF
	ELSEIF ( is_sum(lo_isp).EQ.isalg_merge_1
     .	.AND.  ( nitem.GT.1 .OR. EXPLICIT_UVAR(uvar) )  ) THEN 
* ... expression with constants, pseudo-variables and a single variable
* ... like "LIST U/10" or single variable explicit uvars like "DEFINE NEW=U"
	   CALL MERGIFY_CX( lo_cx, uvar, big_cx, status )
	   IF ( status .NE. ferr_ok ) GOTO 5000
	ENDIF

* finalize the result on the stack - it may be the result of some algebra or
* a simple variable or a constant or pseudo-variable
* "temporary variables" are the result of algebraic operations
* ... re-catalog them under their user-variable names
* explicit user-defined variables (e.g. "DEFINE VAR NEW=X"; "LIST NEW") are
* always re-cataloged under the user-defined name
* Merged context info is then passed back to the calling context.
* implicit uvars that are single pseudo-variables or constants are left as-is
* ... to be deleted as soon as used (e.g. "LIST X")
* implicit uvars that are single variables (e.g. "LIST U") need their "in-use"
* flags removed (otherwise done when they're used as operands)
	IF ( mr_category( hi_mr ) .EQ. cat_temp_var ) THEN
* ... result of algebraic computation
* ... if user set the missing value flag make sure it is used
	   IF ( cx_bad_data(big_cx) .NE. mr_bad_data(hi_mr) ) THEN
	      size = MGRID_SIZE( hi_mr )
	      CALL REPLACE_BAD_DATA_SUB ( mr_bad_data(hi_mr),
     .			                  memory(1,mr_blk1(hi_mr)), size,
     .                                    cx_bad_data(big_cx)  )
	   ENDIF
	   CALL RE_ASSIGN_VARIABLE( hi_mr, big_cx )
	   CALL PASS_AMBIG_LIMS( lo_cx, hi_mr, status )
	   IF ( status .NE. ferr_ok ) GOTO 5000
!	ELSEIF (mr_category(hi_mr) .EQ. cat_string) THEN
!! ... string variables not yet implemented 1/99 *sh*
!	   GOTO 5100
        ELSEIF  (mr_category(hi_mr) .EQ. cat_attrib_val) THEN  ! like the final ELSE below
           CALL MR_NOT_IN_USE(hi_mr)
	   CALL TRANSFER_CONTEXT( big_cx, lo_cx )
	ELSEIF ( EXPLICIT_UVAR(uvar) ) THEN
* ... result of a simple definition like DEFINE VARIABLE UAVE=U[K=@AVE]
*	or DEFINE VARIABLE NEW=X
	   CALL CREATE_MEM_VAR( big_cx, new_mr, status )
	   IF ( status .NE. ferr_ok ) GOTO 5000
	   is_mr( lo_isp ) = new_mr
	   CALL COPY_GRID( memory(1,mr_blk1(hi_mr)),  hi_mr,
     .			   memory(1,mr_blk1(new_mr)), new_mr )
	   CALL PASS_AMBIG_LIMS( lo_cx, new_mr, status )
	   IF ( status .NE. ferr_ok ) GOTO 5000
* component no longer needed
* 12/00 allow contstants to be deleted
	   IF ( mr_category(hi_mr) .EQ. cat_constant ) THEN
	      CALL DELETE_VARIABLE(hi_mr)
	   ELSEIF ( mr_category(hi_mr) .NE. cat_pseudo_var ) THEN
	      CALL MR_NOT_IN_USE(hi_mr)
	   ENDIF

!		This change would fix a minor bug that occurs for "enhanced"
!		CDF files and GT files (bn230_cdf.sub3), but it creates more
!		serious problems of ignoring limits restrictions (1:6) in
!			let a = temp[i=90:110:2]; list a[i=1:6]
!		see bn491_dynamic_grids
!	   CALL TRANSFER_CONTEXT( big_cx, lo_cx )	! 3/99 correct cx, too

	ELSE
	   IF ( mr_category(hi_mr) .NE. cat_pseudo_var
     .    .AND. mr_category(hi_mr) .NE. cat_constant   )
     .                                        CALL MR_NOT_IN_USE(hi_mr)
	   CALL TRANSFER_CONTEXT( big_cx, lo_cx )
	ENDIF

* if user set the missing value flag make sure it is used
	IF ( mr_category(hi_mr) .NE. cat_attrib_val) THEN 
	   IF ( cx_bad_data(lo_cx) .NE. mr_bad_data(is_mr(lo_isp))) THEN  
	      new_mr = is_mr(lo_isp)
	      size = MGRID_SIZE( new_mr )
	      CALL REPLACE_BAD_DATA_SUB ( mr_bad_data(new_mr),
     .			               memory(1,mr_blk1(new_mr)), size,
     .                                  cx_bad_data(lo_cx)  )
	      mr_bad_data(new_mr) = cx_bad_data(lo_cx)
	   ELSE
	      new_mr = is_mr(lo_isp)
	      size = MGRID_SIZE( new_mr )
	      CALL CHECK_NAN_DATA_SUB ( memory(1,mr_blk1(new_mr)), size,
     .                                 mr_bad_data(new_mr) )
	   ENDIF
	ENDIF

* pop off context for the last component received and "big" (merged) context

* This diag condition not true when constructing the data with DEFINE DATA/AGG
c	IF ( big_cx .NE. cx_stack_ptr-1
c     .	.OR. big_cx .NE. lo_cx+1 ) WRITE (6, *) 'is_alg_2' ! temp diag

	cx_stack_ptr = cx_stack_ptr - 2
	RETURN 2

* error exit
 5000	RETURN
 5100	CALL ERRMSG(ferr_not_implemented, status,
     .		'Quoted strings may only be function arguments', 
     .		*5000)
 5900	CALL ERRMSG( ferr_internal, status, 'SAMPLE* not startable',
     .		*5000)

	END	
