/*
 * Copyright (C) 2008, 2009. PathScale, LLC. All Rights Reserved.
 */
/*
 *  Copyright (C) 2006, 2007. QLogic Corporation. All Rights Reserved.
 */

/*
 * Copyright 2003, 2004, 2005, 2006 PathScale, Inc.  All Rights Reserved.
 */

/*

  Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.

   Path64 is free software; you can redistribute it and/or modify it
   under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2, or (at your option)
   any later version.

   Path64 is distributed in the hope that it will be useful, but WITHOUT
   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
   or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
   License for more details.

   You should have received a copy of the GNU General Public License
   along with Path64; see the file COPYING.  If not, write to the Free
   Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
   02110-1301, USA.

   Special thanks goes to SGI for their continued support to open source

*/



static char USMID[] = "\n@(#)5.0_pl/sources/s_utils.c	5.12	10/19/99 17:14:30\n";


# include "defines.h"		/* Machine dependent ifdefs */

# include "host.m"		/* Host machine dependent macros.*/
# include "host.h"		/* Host machine dependent header.*/
# include "target.m"		/* Target machine dependent macros.*/
# include "target.h"		/* Target machine dependent header.*/

# include "globals.m"
# include "tokens.m"
# include "sytb.m"
# include "s_globals.m"
# include "debug.m"
# include "s_utils.m"

# include "globals.h"
# include "tokens.h"
# include "sytb.h"
# include "s_globals.h"

# if defined(_HOST_OS_UNICOS) && defined(_TARGET_OS_UNICOS)
# include <fortran.h>
# endif
#ifdef KEY /* Bug 6845 */
/* Incredibly, there seems to be no single central definition for the limit
 * on subscripts in this front end. Often it's a hard-coded "7". This gives
 * us STATIC_SUBSCRIPT_SIZE, which is used in only one other place. Sigh. */
#include "i_cvrt.h"
#endif /* KEY Bug 6845 */


/*****************************************************************\
|* function prototypes of static functions declared in this file *|
\*****************************************************************/

static int      opr_to_str(operator_type, char *);
static int      create_dv_type_code(int);
static long64   create_imp_do_loops(opnd_type *);
static void     just_find_dope_and_rank(opnd_type *, int *, int *);
static void     compute_char_element_len(opnd_type *,
				               opnd_type *, opnd_type *);
static void	gen_conform_check_call(opnd_type *, opnd_type *, int, int, int);
static void	gen_bounds_check_call(char *, opnd_type *, opnd_type *,
                                      opnd_type *, int, int, int);
static void	gen_rbounds_check_call(char *, opnd_type *, opnd_type *,
                                       opnd_type *, opnd_type *,
                                       opnd_type *, int, int, int);
static void	gen_sbounds_check_call(char *, opnd_type *, opnd_type *, 
                                       opnd_type *, int, int
#ifdef KEY /* Bug 7969 */
                                       , boolean
#endif /* KEY Bug 7969 */
				       );
static void	gen_ptr_chk_call(char *, int, opnd_type *, int, int);
static int	put_file_name_in_cn(int);
static int	put_c_str_in_cn(char *);
static void	gen_dv_def_loops(opnd_type *);
static void	gen_init_stmt(opnd_type *, int, sh_position_type);
static void	reshape_reference_subscripts(opnd_type *);
static void	gen_dv_stride_mult(opnd_type *, int, opnd_type *,
                                   expr_arg_type *, int, int, int);

#ifdef KEY /* Bug 8502 */

/*
 * Remove predicate of an "if" statement by assigning it to a compiler temp
 * and using the temp as the predicate instead. This is needed by the bounds
 * check code because a subscript might contain an operation like "count" or
 * "all" which is not acceptable to the WHIRL generator when it appears
 * directly as the predicate of an "if".
 *
 * if_sh_idx	sh_idx for "if" statement
 */
static void
isolate_if_predicate(int if_sh_idx)
{
  int save_sh_idx = curr_stmt_sh_idx;
  curr_stmt_sh_idx = if_sh_idx;
  short_circuit_high_level_if();
  curr_stmt_sh_idx = save_sh_idx;
}
#endif /* KEY Bug 8502 */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	resolve defined operators and assignment.                             *|
|*									      *|
|* Input parameters:							      *|
|*	opnd - sub tree of operator.                                          *|
|*									      *|
|* Output parameters:							      *|
|*									      *|
|* Returns:								      *|
|*	TRUE - if operator resolved ok.                                       *|
|*									      *|
\******************************************************************************/

boolean resolve_ext_opr(opnd_type 	*opnd,
                        boolean          issue_msg,
                        boolean		 save_in_call_list,
			boolean		 err_res,
                        boolean         *semantically_correct,
                        expr_arg_type   *exp_desc_l,
                        expr_arg_type   *exp_desc_r)

{
   opnd_type	arg_1_opnd;
   opnd_type	arg_2_opnd;
   int		arg_idx;
   int		attr_idx;
   int		col;
   int		darg_idx;

# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
   int		false_list_idx 		= NULL_IDX;
# endif

   boolean	found			= FALSE;
   int		gen_idx			= NULL_IDX;
   int		i;
   int		idx;
   int		info_idx;
   int          ir_idx;
   boolean      is_function		= TRUE;
   int          len;
   int		line;
   int		list_idx;
   int		list1_idx;
   int		list2_idx;
   int		loc_idx;
   int		name_idx;
   int		num_args;
   boolean	ok			= TRUE;
   int		opnd_column;
   int		opnd_line;
   int		rslt_idx;
   int          save_arg_info_list_base;
   int		save_curr_stmt_sh_idx;
   int		save_defer_stmt_expansion;
   int		spec_idx		= NULL_IDX;
   int          sn_idx			= NULL_IDX;
   char         str_word[32];
   opnd_type    tmp_opnd;
   char         type_str_l[45];
   char         type_str_r[45];


   TRACE (Func_Entry, "resolve_ext_opr", NULL);

   /* do memory management stuff to make sure the tables are big enough */

   if (max_call_list_size >= arg_list_size) {
      enlarge_call_list_tables();
   }

   save_arg_info_list_base = arg_info_list_base;
   arg_info_list_base      = arg_info_list_top;
   arg_info_list_top       = arg_info_list_base + 2;

   if (arg_info_list_top >= arg_info_list_size) {
      enlarge_info_list_table();
   }

   ir_idx = OPND_IDX((*opnd));
   line = IR_LINE_NUM(ir_idx);
   col  = IR_COL_NUM(ir_idx);

   if (IR_OPR(ir_idx) == Defined_Bin_Opr) {

      gen_idx  = IR_IDX_L(ir_idx);
      strncpy(str_word, AT_OBJ_NAME_PTR(gen_idx), AT_NAME_LEN(gen_idx));
      str_word[AT_NAME_LEN(gen_idx)] = '\0';
      num_args = 2;
      COPY_OPND(arg_1_opnd, IL_OPND(IR_IDX_R(ir_idx)));
      COPY_OPND(arg_2_opnd, IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx))));

      if (cif_flags & XREF_RECS) {
         cif_usage_rec(gen_idx, AT_Tbl_Idx, line, col, CIF_Symbol_Reference);
      }
   }
   else if (IR_OPR(ir_idx) == Defined_Un_Opr) {
      gen_idx  = IR_IDX_L(ir_idx);
      strncpy(str_word, AT_OBJ_NAME_PTR(gen_idx), AT_NAME_LEN(gen_idx));
      str_word[AT_NAME_LEN(gen_idx)] = '\0';
      num_args = 1;
      COPY_OPND(arg_1_opnd, IR_OPND_R(ir_idx));

      if (cif_flags & XREF_RECS) {
         cif_usage_rec(gen_idx, AT_Tbl_Idx, line, col, CIF_Symbol_Reference);
      }
   }
   else {
      len	= opr_to_str(IR_OPR(ir_idx), str_word);
      gen_idx	= srch_sym_tbl(str_word, len, &name_idx);

      if (gen_idx == NULL_IDX) {
         gen_idx	 = srch_host_sym_tbl(str_word, len, &name_idx, TRUE);
      }

      COPY_OPND(arg_1_opnd, IR_OPND_L(ir_idx));

      if (IR_FLD_R(ir_idx) == NO_Tbl_Idx) {
         num_args = 1;
      }
      else {
         num_args = 2;
         COPY_OPND(arg_2_opnd, IR_OPND_R(ir_idx));
      }
   }

   if (IR_OPR(ir_idx) == Asg_Opr) {
      is_function = FALSE;
   }

   if (gen_idx   == NULL_IDX               ||
       AT_OBJ_CLASS(gen_idx) != Interface) {
      gen_idx = NULL_IDX;
      goto EXIT;
   }

   for (i = 0; i < ATI_NUM_SPECIFICS(gen_idx); i++) {

      sn_idx	= (sn_idx == NULL_IDX) ? ATI_FIRST_SPECIFIC_IDX(gen_idx) :
                                         SN_SIBLING_LINK(sn_idx);
      spec_idx	= SN_ATTR_IDX(sn_idx);

      /* check number, type etc. for match with arg list */

      if (ATP_EXTRA_DARG(spec_idx)) {

         if (num_args != ATP_NUM_DARGS(spec_idx) - 1) {
            continue;
         }

         darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + 1);
      }
      else {

         if (num_args != ATP_NUM_DARGS(spec_idx)) {
            continue;
         }

         darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx));
      }

      /* look at each actual arg for match */

      if (darg_idx == NULL_IDX) {
         continue;
      }

      if (AT_OBJ_CLASS(darg_idx) == Data_Obj) {

         if (ATD_IGNORE_TKR(darg_idx)) {
            /* intentionally blank */
            /* This dummy arg will match any type, so skip */
            /* the type and kind type checking below.      */
         }
         else if (OPND_FLD(arg_1_opnd) == IR_Tbl_Idx &&
                  IR_OPR(OPND_IDX(arg_1_opnd)) == Null_Intrinsic_Opr) {
            /* intentionally blank */
            /* Don't know type or rank yet, they come from dummy */
         }
         else if (TYP_TYPE(ATD_TYPE_IDX(darg_idx)) != exp_desc_l->type) {
            continue;
         }
         else if (exp_desc_l->type == Structure) {

            if (!compare_derived_types(exp_desc_l->type_idx,
                                       ATD_TYPE_IDX(darg_idx))) {
               continue;
            }
         }
         else if (exp_desc_l->type != Character   &&
           TYP_LINEAR(ATD_TYPE_IDX(darg_idx)) != exp_desc_l->linear_type) {
            continue;
         }

         if (ATD_IGNORE_TKR(darg_idx)) {
            /* intentionally blank */
            /* This dummy arg will match any rank, so skip */
            /* the rank checking below.      */
         }
         else if (OPND_FLD(arg_1_opnd) == IR_Tbl_Idx &&
                  IR_OPR(OPND_IDX(arg_1_opnd)) == Null_Intrinsic_Opr) {
            /* intentionally blank */
            /* Don't know type or rank yet, they come from dummy */
         }
         else if (ATP_ELEMENTAL(spec_idx)) {
            /* intentionally blank, don't check array conformance */
         }
         else if (ATD_ARRAY_IDX(darg_idx) == NULL_IDX) {
       
            if (exp_desc_l->rank) {
               continue;
            }
         }
         else {

            if (BD_RANK(ATD_ARRAY_IDX(darg_idx)) != exp_desc_l->rank) {
               continue;
            }
         }
      }
      else if (AT_OBJ_CLASS(darg_idx) == Pgm_Unit) {
         /* not sure this is possible */
      }

      if (num_args == 2) {
         if (ATP_EXTRA_DARG(spec_idx)) {
            darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + 2);
         }
         else {
            darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + 1);
         }
         /* look at each actual arg for match */
   
         if (darg_idx == NULL_IDX) {
            continue;
         }
      
         if (AT_OBJ_CLASS(darg_idx) == Data_Obj) {

            if (ATD_IGNORE_TKR(darg_idx)) {
               /* intentionally blank */
               /* This dummy arg will match any type, so skip */
               /* the type and kind type checking below.      */
            }
            else if (OPND_FLD(arg_2_opnd) == IR_Tbl_Idx &&
                     IR_OPR(OPND_IDX(arg_2_opnd)) == Null_Intrinsic_Opr) {
               /* intentionally blank */
               /* Don't know type or rank yet, they come from dummy */
            }
            else if (TYP_TYPE(ATD_TYPE_IDX(darg_idx)) != exp_desc_r->type) {
               continue;
            }
            else if (exp_desc_r->type == Structure) {

               if (!compare_derived_types(exp_desc_r->type_idx, 
                                          ATD_TYPE_IDX(darg_idx))) {
                  continue;
               }
            }
            else if (exp_desc_r->type != Character && 
            TYP_LINEAR(ATD_TYPE_IDX(darg_idx)) != exp_desc_r->linear_type) {
               continue;
            }

            if (ATD_IGNORE_TKR(darg_idx)) {
               /* intentionally blank */
               /* This dummy arg will match any rank, so skip */
               /* the rank checking below.      */
            }
            else if (OPND_FLD(arg_2_opnd) == IR_Tbl_Idx &&
                     IR_OPR(OPND_IDX(arg_2_opnd)) == Null_Intrinsic_Opr) {
               /* intentionally blank */
               /* Don't know type or rank yet, they come from dummy */
            }
            else if (ATP_ELEMENTAL(spec_idx)) {
               /* intentionally blank, don't check array conformance */
            }
            else if (ATD_ARRAY_IDX(darg_idx) == NULL_IDX) {
          
               if (exp_desc_r->rank) {
                  continue;
               }
            }
            else {

               if (BD_RANK(ATD_ARRAY_IDX(darg_idx)) != exp_desc_r->rank) {
                  continue;
               }
            }
         }
         else if (AT_OBJ_CLASS(darg_idx) == Pgm_Unit) {
            /* not sure this is possible */
         }
      }

      /* if still here, I found it */

      /* only issue usage rec here if overloaded intrinsic opr. */
      /* user defined opers (.opr.) are handled earlier.        */

      if (cif_flags & XREF_RECS &&
          IR_OPR(ir_idx) != Defined_Bin_Opr &&
          IR_OPR(ir_idx) != Defined_Un_Opr) {

         cif_usage_rec(gen_idx, AT_Tbl_Idx, line, col, CIF_Symbol_Reference);
      }

      if (ATP_SCP_IDX(spec_idx) != curr_scp_idx || AT_NOT_VISIBLE(spec_idx)) {

         /* Not visible is checked, because a not visible procedure */
         /* may be referenced via its interface name, even though   */
         /* it cannot be referenced via its own name.               */

         attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(spec_idx),
                                 AT_NAME_LEN(spec_idx),
                                 &name_idx);

         if (attr_idx != spec_idx) {

            /* This attr is not in this scope.  It is either host associated */
            /* here, via the interface block, or it is USE_ASSOCIATED, but   */
            /* is not in the local symbol table.                             */

            ADD_ATTR_TO_LOCAL_LIST(spec_idx);
         }
      }

      AT_REFERENCED(spec_idx) = Referenced;

      if (exp_desc_l->reference           &&
          (cif_flags & XREF_RECS) != 0    &&
          xref_state != CIF_No_Usage_Rec) {

         COPY_OPND(tmp_opnd, arg_1_opnd);

         while (OPND_FLD(tmp_opnd)         == IR_Tbl_Idx  &&
                IR_OPR(OPND_IDX(tmp_opnd)) != Struct_Opr) {

            COPY_OPND(tmp_opnd, IR_OPND_L(OPND_IDX(tmp_opnd)));
         }

         find_opnd_line_and_column(&tmp_opnd, &opnd_line, &opnd_column);

         cif_usage_rec(OPND_IDX(tmp_opnd), 
                       OPND_FLD(tmp_opnd), 
                       opnd_line,
                       opnd_column,
                       CIF_Symbol_Defined_Opr_Actual_Arg);
      }

      NTR_IR_LIST_TBL(list1_idx);
      IL_ARG_DESC_VARIANT(list1_idx) = TRUE;
      COPY_OPND(IL_OPND(list1_idx), arg_1_opnd);

      info_idx                               = arg_info_list_base + 1;
      arg_info_list[info_idx]                = init_arg_info;
      arg_info_list[info_idx].ed             = *exp_desc_l;
      arg_info_list[info_idx].maybe_modified = TRUE;
      IL_ARG_DESC_IDX(list1_idx)             = info_idx;
   
      if (num_args == 2) {

         if (exp_desc_r->reference           &&
             (cif_flags & XREF_RECS) != 0    &&
             xref_state != CIF_No_Usage_Rec) {

            COPY_OPND(tmp_opnd, arg_2_opnd);

            while (OPND_FLD(tmp_opnd)         == IR_Tbl_Idx  &&
                   IR_OPR(OPND_IDX(tmp_opnd)) != Struct_Opr) {

               COPY_OPND(tmp_opnd, IR_OPND_L(OPND_IDX(tmp_opnd)));
            }

            find_opnd_line_and_column(&tmp_opnd, &opnd_line, &opnd_column);

            cif_usage_rec(OPND_IDX(tmp_opnd),
                          OPND_FLD(tmp_opnd), 
                          opnd_line,
                          opnd_column,
                          CIF_Symbol_Defined_Opr_Actual_Arg);
         }


         NTR_IR_LIST_TBL(list2_idx);
         IL_ARG_DESC_VARIANT(list2_idx) = TRUE;
         COPY_OPND(IL_OPND(list2_idx), arg_2_opnd);
         IL_NEXT_LIST_IDX(list1_idx) = list2_idx;

         info_idx++;

         arg_info_list[info_idx]                = init_arg_info;
         arg_info_list[info_idx].ed             = *exp_desc_r;
         arg_info_list[info_idx].maybe_modified = TRUE;
         IL_ARG_DESC_IDX(list2_idx)             = info_idx;
      }

      IR_FLD_L(ir_idx)         = AT_Tbl_Idx;
      IR_IDX_L(ir_idx)         = spec_idx;
      IR_LINE_NUM_L(ir_idx)    = IR_LINE_NUM(ir_idx);
      IR_COL_NUM_L(ir_idx)     = IR_COL_NUM(ir_idx);
      IR_FLD_R(ir_idx)         = IL_Tbl_Idx;
      IR_IDX_R(ir_idx)         = list1_idx;
      IR_LIST_CNT_R(ir_idx)    = num_args;
      IR_OPR(ir_idx)           = Call_Opr;
      /* set the type to short typeless for now. */
      /* will be changed later.                  */
      IR_TYPE_IDX(ir_idx)      = TYPELESS_DEFAULT_TYPE;

      if (defer_stmt_expansion) {
         number_of_functions++;
      }

      save_curr_stmt_sh_idx = curr_stmt_sh_idx;

      SCP_HAS_CALLS(curr_scp_idx) = TRUE;


      /* If Usage records are not being generated, then don't produce a Call  */
      /* Site record either.  Example:					      */
      /* 								      */
      /*     result = func(arg)						      */
      /* 								      */
      /* where FUNC is a generic identifier pulled in from a module where     */
      /* the specific procedure being called is declared something like       */
      /* 								      */
      /*     FUNCTION func(string) RESULT(char)				      */
      /* 								      */
      /* where CHAR result depends on the value of an expression like	      */
      /* 								      */
      /*     CHARACTER(LEN=SIZE(string%content)) :: char		      */
      /* 								      */
      /* As a part of evaluating FUNC, we don't want to see a Call Site       */
      /* record generated as a part of processing SIZE (it will also have     */
      /* line numbers from the module in its IR tree which are meaningless.   */
      /* See also the cif_call_site_rec call in s_call.c.		      */
   
      if ((cif_flags & MISC_RECS) != 0  &&  xref_state != CIF_No_Usage_Rec) {
         cif_call_site_rec(ir_idx, gen_idx);
      }

      if (AT_OBJ_CLASS(spec_idx)  == Pgm_Unit   &&
          ATP_SCP_ALIVE(spec_idx))              {

         if (ATP_PGM_UNIT(spec_idx)  == Function && 
             !ATP_RSLT_NAME(spec_idx)) {
            PRINTMSG(IR_LINE_NUM(ir_idx), 344, Ansi, IR_COL_NUM(ir_idx));
         }

         if (!ATP_RECURSIVE(spec_idx) && !AT_DCL_ERR(spec_idx) &&
             !on_off_flags.recursive) {
            PRINTMSG(IR_LINE_NUM(ir_idx), 343, Error, IR_COL_NUM(ir_idx));
            *semantically_correct = FALSE;
         }
      }

      if (AT_DCL_ERR(spec_idx)) {
         /* don't do any further processing on this bad boy */

         *semantically_correct = FALSE;
         curr_stmt_sh_idx = save_curr_stmt_sh_idx;
         found = TRUE;
         goto EXIT;
      }

      stmt_expansion_control_start();
      save_defer_stmt_expansion = defer_stmt_expansion;
      defer_stmt_expansion = FALSE;

      if (is_function) {

         /* need to do temp and assign here */

         in_call_list		= save_in_call_list;
         rslt_idx		= ATP_RSLT_IDX(spec_idx);
         (*exp_desc_l)		= init_exp_desc;

         exp_desc_l->type_idx    = ATD_TYPE_IDX(rslt_idx);
         exp_desc_l->type        = TYP_TYPE(exp_desc_l->type_idx);
         exp_desc_l->linear_type = TYP_LINEAR(exp_desc_l->type_idx);
         exp_desc_l->pointer     = ATD_POINTER(rslt_idx);
         exp_desc_l->target      = ATD_TARGET(rslt_idx);
         exp_desc_l->allocatable = ATD_ALLOCATABLE(rslt_idx);
         exp_desc_l->dope_vector = ATD_IM_A_DOPE(rslt_idx);

         IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(rslt_idx);

         if (ATD_ARRAY_IDX(ATP_RSLT_IDX(spec_idx))) {
            exp_desc_l->assumed_shape =
                    (BD_ARRAY_CLASS(ATD_ARRAY_IDX(rslt_idx)) == Assumed_Shape);
            exp_desc_l->assumed_size  =
                    (BD_ARRAY_CLASS(ATD_ARRAY_IDX(rslt_idx)) == Assumed_Size);
            exp_desc_l->rank = BD_RANK(ATD_ARRAY_IDX(rslt_idx));
         }


         if (!no_func_expansion)   {

            flatten_function_call(opnd);

            if (ATP_ELEMENTAL(spec_idx)) {

               attr_idx = find_base_attr(opnd, &line, &col);
               exp_desc_l->rank = BD_RANK(ATD_ARRAY_IDX(attr_idx));
            }


            /* Now that the types for the function result, etc. have been     */
            /* resolved, the Object record that represents the function       */
            /* result can now be output.                                      */

            if ((cif_flags & MISC_RECS) != 0  && 
                xref_state != CIF_No_Usage_Rec) {
               cif_object_rec_for_func_result(spec_idx);
            }

            exp_desc_l->tmp_reference = TRUE;

            if (exp_desc_l->type == Character ||
                exp_desc_l->rank)             {

               attr_idx = find_base_attr(opnd, &line, &col);

               if (exp_desc_l->type == Character) {
                  IR_TYPE_IDX(ir_idx)      = ATD_TYPE_IDX(attr_idx);
                  exp_desc_l->type_idx	   = ATD_TYPE_IDX(attr_idx);
                  exp_desc_l->type	   = TYP_TYPE(exp_desc_l->type_idx);
                  exp_desc_l->linear_type  = TYP_LINEAR(exp_desc_l->type_idx);
                  get_char_len(opnd, &(exp_desc_l->char_len));
               }

               if (exp_desc_l->rank) {
                  get_shape_from_attr(exp_desc_l,
                                      attr_idx,
                                      exp_desc_l->rank,
                                      line,
                                      col);

                  exp_desc_l->contig_array = TRUE;
               }
            }
         }
         else {
            set_shape_for_deferred_funcs(exp_desc_l, ir_idx);
         }

         IR_TYPE_IDX(ir_idx)	= exp_desc_l->type_idx;
         IR_RANK(ir_idx)	= exp_desc_l->rank;
      }

      if (!no_func_expansion)   {

         if (! is_function) {
            /* this was done for functions under flatten_func_call */

            COPY_OPND(tmp_opnd, IR_OPND_R(ir_idx));
            ok = final_arg_work(&tmp_opnd, spec_idx, num_args, NULL,
#ifdef KEY /* Bug 8090 (Sicortex) */
	      ir_idx
#endif /* Bug 8090 (Sicortex) */
	      ) && ok;
            COPY_OPND(IR_OPND_R(ir_idx), tmp_opnd);
         }

         if (ATP_PROC(spec_idx) != Dummy_Proc &&
             ATP_PROC(spec_idx) != Intrin_Proc &&
             ! ATP_VFUNCTION(spec_idx) &&
             (cmd_line_flags.runtime_argument ||
             cmd_line_flags.runtime_arg_call)) {

# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
            list1_idx = IR_IDX_R(ir_idx);
            list2_idx = NULL_IDX;

            idx = 0;

            while (list1_idx) {
               if (IL_FLD(list1_idx) == IR_Tbl_Idx &&
                   IR_OPR(IL_IDX(list1_idx)) == False_Parm_Opr) {

                  false_list_idx = list1_idx;

                  IL_NEXT_LIST_IDX(list2_idx) = NULL_IDX;
                  break;
               }

               list2_idx = list1_idx;
               list1_idx = IL_NEXT_LIST_IDX(list1_idx);
               idx++;
            }

            IR_LIST_CNT_R(ir_idx) = idx;
# endif

            ATP_ARGCHCK_CALL(spec_idx) = TRUE;

            NTR_IR_TBL(loc_idx);
            IR_OPR(loc_idx) = Aloc_Opr;
            IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
            IR_LINE_NUM(loc_idx) = line;
            IR_COL_NUM(loc_idx) = col;
            IR_FLD_L(loc_idx) = AT_Tbl_Idx;

            OPND_FLD(tmp_opnd) = IR_Tbl_Idx;
            OPND_IDX(tmp_opnd) = ir_idx;
            idx = create_argchck_descriptor(&tmp_opnd);
            IR_IDX_L(loc_idx) = idx;
            IR_LINE_NUM_L(loc_idx) = line;
            IR_COL_NUM_L(loc_idx) = col;

            NTR_IR_LIST_TBL(list2_idx);
            IL_ARG_DESC_VARIANT(list2_idx) = TRUE;
            IL_FLD(list2_idx) = IR_Tbl_Idx;
            IL_IDX(list2_idx) = loc_idx;

            if (IR_LIST_CNT_R(ir_idx) == 0) {
               IR_FLD_R(ir_idx) = IL_Tbl_Idx;
               IR_IDX_R(ir_idx) = list2_idx;
               IR_LIST_CNT_R(ir_idx) = 1;
            }
            else {
               list1_idx = IR_IDX_R(ir_idx);
               while (IL_NEXT_LIST_IDX(list1_idx)) {
                  list1_idx = IL_NEXT_LIST_IDX(list1_idx);
               }

               IL_NEXT_LIST_IDX(list1_idx) = list2_idx;
               (IR_LIST_CNT_R(ir_idx))++;
            }

# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
            if (false_list_idx != NULL_IDX) {
               IL_NEXT_LIST_IDX(list2_idx) = false_list_idx;
               list1_idx = false_list_idx;
               while (list1_idx) {
                  (IR_LIST_CNT_R(ir_idx))++;
                  list1_idx = IL_NEXT_LIST_IDX(list1_idx);
               }
            }
# endif
         }
      }

      defer_stmt_expansion = save_defer_stmt_expansion;
      stmt_expansion_control_end(opnd);

      curr_stmt_sh_idx = save_curr_stmt_sh_idx;

      found = TRUE;
      break;
   }

EXIT:

   if (ok && found && (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
                       ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx)))) {

      if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx))) {

         if (!ATP_PURE(spec_idx) && !ATP_ELEMENTAL(spec_idx)) {
            PRINTMSG(IR_LINE_NUM(ir_idx), 1274, Error, IR_COL_NUM(ir_idx),
                     AT_OBJ_NAME_PTR(spec_idx),
                     "pure or elemental",
                     "pure");

         }
      }
      else if (ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {

         if (!ATP_PURE(spec_idx) && !ATP_ELEMENTAL(spec_idx)) {
            PRINTMSG(IR_LINE_NUM(ir_idx), 1274, Error, IR_COL_NUM(ir_idx),
                     AT_OBJ_NAME_PTR(spec_idx),
                     "pure or elemental",
                     "elemental");

         }
      }

      /* Check to make sure that actual arguments are definable if */
      /* the dummy arg has INTENT(out), INTENT(inout) or POINTER.  */

      list_idx  = IR_IDX_R(ir_idx);

      if (ATP_EXTRA_DARG(spec_idx)) {
         arg_idx        = ATP_FIRST_IDX(spec_idx) + 1;
         idx            = ATP_NUM_DARGS(spec_idx) - 1;
      }
      else {
         arg_idx        = ATP_FIRST_IDX(spec_idx);
         idx            = ATP_NUM_DARGS(spec_idx);
      }
      for (;idx > 0; idx--) {

         if (AT_OBJ_CLASS(SN_ATTR_IDX(arg_idx)) == Data_Obj &&
             (ATD_POINTER(SN_ATTR_IDX(arg_idx)) ||
              ATD_INTENT(SN_ATTR_IDX(arg_idx)) == Intent_Inout ||
              ATD_INTENT(SN_ATTR_IDX(arg_idx)) == Intent_Out)) {
            COPY_OPND(tmp_opnd, IL_OPND(list_idx));
            attr_idx = find_left_attr(&tmp_opnd);

            if (AT_OBJ_CLASS(attr_idx) == Data_Obj && ATD_PURE(attr_idx)) {
               find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
                                         &opnd_line,
                                         &opnd_column);
               PRINTMSG(opnd_line, 1273, Error, opnd_column,
                       AT_OBJ_NAME_PTR(attr_idx),
                       AT_OBJ_NAME_PTR(SN_ATTR_IDX(arg_idx)),
                       ATP_PURE(SCP_ATTR_IDX(curr_scp_idx))?"pure":"elemental");
               ok       = FALSE;


            }
         }
         arg_idx++;
         list_idx       = IL_NEXT_LIST_IDX(list_idx);
      }
   }

   if (found) {

      /* If spec is not equal to gen, that means the names are not the same. */
      /* If the names are not the same, then we didn't actually specify the  */
      /* specific name, so we don't care if it is invisible.                 */

      if (spec_idx == gen_idx && AT_NOT_VISIBLE(spec_idx)) {
          PRINTMSG(IR_LINE_NUM(ir_idx), 486, Error, 
                   IR_COL_NUM(ir_idx),
                   AT_OBJ_NAME_PTR(spec_idx),
                   AT_OBJ_NAME_PTR(AT_MODULE_IDX((spec_idx))));
         *semantically_correct = FALSE;
      }

      switch (expr_mode) {
         case Restricted_Imp_Do_Expr:
         case Data_Stmt_Target_Expr:
            PRINTMSG(IR_LINE_NUM(ir_idx), 62, Error, 
                     IR_COL_NUM(ir_idx),
                     str_word);
            *semantically_correct = FALSE;
            break;

         case Specification_Expr:
            PRINTMSG(IR_LINE_NUM(ir_idx), 880, Error,
                     IR_COL_NUM(ir_idx),
                     str_word);
            *semantically_correct = FALSE;
            break;

         case Stmt_Func_Expr:
            PRINTMSG(IR_LINE_NUM(ir_idx), 757, Error,
                     IR_COL_NUM(ir_idx),
                     str_word);
            *semantically_correct = FALSE;
            break;
      }
   }
   else if (issue_msg) {

      if (gen_idx != NULL_IDX)  {
         PRINTMSG(IR_LINE_NUM(ir_idx), 380, Error, 
                   IR_COL_NUM(ir_idx), str_word);
         *semantically_correct = FALSE;
      }
      else {
      
         if (exp_desc_l->linear_type == Long_Typeless ||
             (num_args == 2 && exp_desc_r->linear_type == Long_Typeless)) {

            if (exp_desc_l->linear_type == Long_Typeless) {
               find_opnd_line_and_column((opnd_type *) &IR_OPND_L(ir_idx),
                                         &opnd_line,
                                         &opnd_column);
               PRINTMSG(opnd_line, 1133, Error, opnd_column);
               *semantically_correct = FALSE;
            }

            if (num_args == 2 &&
                exp_desc_r->linear_type == Long_Typeless) {
               find_opnd_line_and_column((opnd_type *) &IR_OPND_R(ir_idx),
                                         &opnd_line,
                                         &opnd_column);
               PRINTMSG(opnd_line, 1133, Error, opnd_column);
               *semantically_correct = FALSE;
            }
         }
         else if (! is_function) { /* assignment */

            if (exp_desc_r->rank != exp_desc_l->rank && exp_desc_r->rank != 0) {

               /* rank error */

               PRINTMSG(IR_LINE_NUM(ir_idx), 324, Error, IR_COL_NUM(ir_idx),
                        exp_desc_r->rank, exp_desc_l->rank);
               *semantically_correct = FALSE;
            }

            if (err_res) {
               strcpy(type_str_l, get_basic_type_str(exp_desc_l->type_idx));
               strcpy(type_str_r, get_basic_type_str(exp_desc_r->type_idx));

               PRINTMSG(IR_LINE_NUM(ir_idx), 356, Error,
                        IR_COL_NUM(ir_idx),
                        type_str_r,
                        type_str_l);
               *semantically_correct = FALSE;
            }
         }
         else if (expr_mode == Restricted_Imp_Do_Expr ||
                  expr_mode == Data_Stmt_Target_Expr) {

            PRINTMSG(IR_LINE_NUM(ir_idx), 62, Error,
                     IR_COL_NUM(ir_idx), str_word);
            *semantically_correct = FALSE;
         }
         else if (num_args == 1) { /* unary operator */

            PRINTMSG(IR_LINE_NUM(ir_idx), 392, Error,
                     IR_COL_NUM(ir_idx), 
                     get_basic_type_str(exp_desc_l->type_idx),
                     str_word);
            *semantically_correct = FALSE;
         }
         else {
            /* binary operator */

            if (exp_desc_r->rank != exp_desc_l->rank      &&
                exp_desc_r->rank * exp_desc_l->rank != 0) {

               /* rank error */

               PRINTMSG(IR_LINE_NUM(ir_idx), 302, Error, IR_COL_NUM(ir_idx),
                        exp_desc_l->rank, exp_desc_r->rank, str_word);
               *semantically_correct = FALSE;
            }

            if (err_res) {

#ifdef KEY /* Bug 5710, 8094 */
	     /* If we're allowing intrinsic .eq. on logical operands as an
	      * extension, the absence of an overloaded function is not an
	      * error; we'll return to our caller who will use the intrinsic
	      * operator. */
	     if (!((Eq_Opr == IR_OPR(ir_idx) || Ne_Opr == IR_OPR(ir_idx)) &&
	       eq_ne_on_logical(0, exp_desc_l, exp_desc_r))) {
#endif /* KEY Bug 5710, 8094 */

               strcpy(type_str_l, get_basic_type_str(exp_desc_l->type_idx));
               strcpy(type_str_r, get_basic_type_str(exp_desc_r->type_idx));

               PRINTMSG(IR_LINE_NUM(ir_idx), 303, Error,
                        IR_COL_NUM(ir_idx),
                        type_str_l,
                        type_str_r,
                        str_word);
               *semantically_correct = FALSE;
#ifdef KEY /* Bug 5710 */
	     }
#endif /* KEY Bug 5710 */
            }
         }
      }
   }

   if (*semantically_correct &&
       found &&
       ATP_PROC(spec_idx) != Intrin_Proc) {

#ifdef KEY /* Bug 7726 */
      /* Fortran 95 says every elemental procedure is pure */
      if (! (ATP_PURE(spec_idx) || ATP_ELEMENTAL(spec_idx)))
#else /* KEY Bug 7726 */
      if (! ATP_PURE(spec_idx))
#endif /* KEY Bug 7726 */
      {
         if (within_forall_mask_expr) {
            PRINTMSG(IR_LINE_NUM(ir_idx), 1611, Error, IR_COL_NUM(ir_idx), 
                     AT_OBJ_NAME_PTR(spec_idx),
                     "forall scalar-mask-expr");
            *semantically_correct = FALSE;
         }
         else if (within_forall_construct) {
            PRINTMSG(IR_LINE_NUM(ir_idx), 1611, Error, IR_COL_NUM(ir_idx), 
                     AT_OBJ_NAME_PTR(spec_idx),
                     "forall-body-construct");
            *semantically_correct = FALSE;
         }
      }
   }

   if (found) {
      PRINTMSG(IR_LINE_NUM(ir_idx), 399, Comment, IR_COL_NUM(ir_idx),
               str_word, AT_OBJ_NAME_PTR(spec_idx));
   }

   /* restore arg_info_list to previous "stack frame" */

   arg_info_list_top  = arg_info_list_base;
   arg_info_list_base = save_arg_info_list_base;

   TRACE (Func_Exit, "resolve_ext_opr", NULL);

   return(found);

}  /* resolve_ext_opr */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Return a string for any expression opr.                               *|
|*									      *|
|* Input parameters:							      *|
|*	opr - the operator.                                                   *|
|*									      *|
|* Output parameters:							      *|
|*	str - the string.                                                     *|
|*									      *|
|* Returns:								      *|
|*	length of str							      *|
|*									      *|
\******************************************************************************/

static int  opr_to_str(operator_type	opr,
                       char	       *str)

{
   int	i;
   int  len = 0;

   TRACE (Func_Entry, "opr_to_str", NULL);

   for (i = 0; i < 8; i++) {
      str[i] = '\0';
   }

   switch (opr) {
      case Uplus_Opr  :
         strncpy(str, "+", 1);
         len = 1;
         break;
      case Uminus_Opr :
         strncpy(str, "-", 1);
         len = 1;
         break;
      case Power_Opr  :
         strncpy(str, "**", 2);
         len = 2;
         break;
      case Mult_Opr   :
         strncpy(str, "*", 1);
         len = 1;
         break;
      case Div_Opr    :
         strncpy(str, "/", 1);
         len = 1;
         break;
      case Plus_Opr   :
         strncpy(str, "+", 1);
         len = 1;
         break;
      case Minus_Opr  :
         strncpy(str, "-", 1);
         len = 1;
         break;
      case Concat_Opr :
         strncpy(str, "//", 2);
         len = 2;
         break;
      case Eq_Opr     :
         strncpy(str, "eq", 2);
         len = 2;
         break;
      case Ne_Opr     :
         strncpy(str, "ne", 2);
         len = 2;
         break;
      case Lg_Opr     :
         strncpy(str, "lg", 2);
         len = 2;
         break;
      case Lt_Opr     :
         strncpy(str, "lt", 2);
         len = 2;
         break;
      case Le_Opr     :
         strncpy(str, "le", 2);
         len = 2;
         break;
      case Gt_Opr     :
         strncpy(str, "gt", 2);
         len = 2;
         break;
      case Ge_Opr     :
         strncpy(str, "ge", 2);
         len = 2;
         break;
      case Not_Opr    :
         strncpy(str, "not", 3);
         len = 3;
         break;
      case And_Opr    :
         strncpy(str, "and", 3);
         len = 3;
         break;
      case Or_Opr     :
         strncpy(str, "or", 2);
         len = 2;
         break;
      case Eqv_Opr    :
         strncpy(str, "eqv", 3);
         len = 3;
         break;
      case Neqv_Opr   :
         strncpy(str, "neqv", 4);
         len = 4;
         break;
      case Asg_Opr    :
         strncpy(str, "=", 1);
         len = 1;
         break;
   }

   TRACE (Func_Exit, "opr_to_str", NULL);

   return(len);

}  /* opr_to_str */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	finds the base attr pointer from reference tree.                      *|
|*	The difference between find_base_attr and find_left_attr is:          *|
|*									      *|
|*       a%b%c(1:10)(1:3)                                                     *|
|*									      *|
|*       find_base_attr finds 'c'                                             *|
|*       find_left_attr finds 'a'                                             *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

int	find_base_attr(opnd_type       *root_opnd,
                       int	       *line,
                       int	       *col)

{
   int		attr_idx = NULL_IDX;
   opnd_type	opnd;

   TRACE (Func_Entry, "find_base_attr", NULL);

   *line = 0;
   *col  = 0;

   COPY_OPND(opnd, (*root_opnd));

   while (attr_idx == NULL_IDX) {
      switch (OPND_FLD(opnd)) {
         case AT_Tbl_Idx :
            attr_idx = OPND_IDX(opnd);
            *line    = OPND_LINE_NUM(opnd);
            *col     = OPND_COL_NUM(opnd);
            goto EXIT;

         case IR_Tbl_Idx :

            if (IR_OPR(OPND_IDX(opnd)) == Struct_Opr) {
               COPY_OPND(opnd, IR_OPND_R(OPND_IDX(opnd)));
            }
            else {
               COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
            }
            break;

         case CN_Tbl_Idx :
            *line = OPND_LINE_NUM(opnd);
            *col  = OPND_COL_NUM(opnd);
            goto EXIT;

         default         :
            goto EXIT;
      }
   }
   
EXIT:

   TRACE (Func_Exit, "find_base_attr", ((attr_idx == NULL_IDX) ? NULL :
                                        AT_OBJ_NAME_PTR(attr_idx)));

   return(attr_idx);

}  /* find_base_attr */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Find the left most attr in a reference tree.                          *|
|*									      *|
|*	The difference between find_base_attr and find_left_attr is:          *|
|*									      *|
|*       a%b%c(1:10)(1:3)                                                     *|
|*									      *|
|*       find_base_attr finds 'c'                                             *|
|*       find_left_attr finds 'a'                                             *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

int	find_left_attr(opnd_type *root_opnd)

{
   int          attr_idx = NULL_IDX;
   opnd_type    opnd;


   TRACE (Func_Entry, "find_left_attr", NULL);

   COPY_OPND(opnd, (*root_opnd));

   while (attr_idx == NULL_IDX) {
      switch (OPND_FLD(opnd)) {
         case AT_Tbl_Idx :
            attr_idx = OPND_IDX(opnd);
            goto EXIT;

         case IR_Tbl_Idx :

            COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
            break;

         default         :
            goto EXIT;
      }
   }

EXIT:

   TRACE (Func_Exit, "find_left_attr", NULL);

   return(attr_idx);

}  /* find_left_attr */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Compares reference subtrees to see if they reference the same object. *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      opnd1, opnd2 - the roots of the two trees.                            *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      TRUE for match.                                                       *|
|*                                                                            *|
\******************************************************************************/

boolean cmp_ref_trees(opnd_type *opnd1,
                      opnd_type *opnd2)

{
   int		column;
   int		line;
   int		list1_idx;
   int		list2_idx;
   boolean	match		= TRUE;


   TRACE (Func_Entry, "cmp_ref_trees", NULL);

   if (OPND_FLD((*opnd1)) != OPND_FLD((*opnd2))) {
      match = FALSE;
   }
   else {
      switch(OPND_FLD((*opnd1))) {
         case NO_Tbl_Idx   :
            match = TRUE;
            break;

         case CN_Tbl_Idx :
         case AT_Tbl_Idx :

            if (OPND_IDX((*opnd1)) == OPND_IDX((*opnd2))) {
               match = TRUE;
            }
            else {
               match = FALSE;
            }
            break;

         case IL_Tbl_Idx :

            if (OPND_LIST_CNT((*opnd1)) == OPND_LIST_CNT((*opnd2))) {
               list1_idx = OPND_IDX((*opnd1));
               list2_idx = OPND_IDX((*opnd2));

               while (list1_idx != NULL_IDX && match) {
                  match = cmp_ref_trees((opnd_type *)&IL_OPND(list1_idx),
                                        (opnd_type *)&IL_OPND(list2_idx));
                  list1_idx = IL_NEXT_LIST_IDX(list1_idx);
                  list2_idx = IL_NEXT_LIST_IDX(list2_idx);
               }
            }
            else {
               match = FALSE;
            }
            break;

         case SH_Tbl_Idx :
            find_opnd_line_and_column(opnd1, &line, &column);
            PRINTMSG(line, 963, Internal, column);
            break;

         case IR_Tbl_Idx :

            if (IR_OPR(OPND_IDX((*opnd1))) == IR_OPR(OPND_IDX((*opnd2)))) { 
               match = cmp_ref_trees((opnd_type*)&IR_OPND_L(OPND_IDX((*opnd1))),
                                    (opnd_type*)&IR_OPND_L(OPND_IDX((*opnd2))));
               match = match &&
                     cmp_ref_trees((opnd_type *)&IR_OPND_R(OPND_IDX((*opnd1))),
                                   (opnd_type *)&IR_OPND_R(OPND_IDX((*opnd2))));
            }
            else {
               match = FALSE;
            }
            break;
      }
   }

   TRACE (Func_Exit, "cmp_ref_trees", NULL);

   return(match);

}  /* cmp_ref_trees */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	malloc or realloc the call list arrays.                               *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void enlarge_call_list_tables(void)

{
   int		new_size;

   TRACE (Func_Entry, "enlarge_call_list_tables", NULL);

   /* CALL_LIST_TBL_INC defined in s_utils.m */
   new_size = ((max_call_list_size/CALL_LIST_TBL_INC) + 1)
              * CALL_LIST_TBL_INC;

   if (arg_list_size == 0) {

      /* must do original malloc */

      MEM_ALLOC(arg_list, int, new_size);

   }
   else { /* do realloc */

      MEM_REALLOC(arg_list, int, new_size);

   }

   arg_list_size = new_size;

   TRACE (Func_Exit, "enlarge_call_list_tables", NULL);

   return;

}  /* enlarge_call_list_tables */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Table manager for arg_info_list table.                                *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void enlarge_info_list_table(void)

{
   int          new_size;

   TRACE (Func_Entry, "enlarge_info_list_table", NULL);

   /* CALL_LIST_TBL_INC defined in s_utils.m */
   new_size = arg_info_list_size + ((max_call_list_size/CALL_LIST_TBL_INC) + 1)
              * CALL_LIST_TBL_INC;

   if (arg_info_list_size == 0) {

      /* must do original malloc */

      MEM_ALLOC(arg_info_list, arg_strct_type, new_size);

   }
   else { /* do realloc */

      MEM_REALLOC(arg_info_list, arg_strct_type, new_size);

   }

   arg_info_list_size = new_size;

   TRACE (Func_Exit, "enlarge_info_list_table", NULL);

   return;

}  /* enlarge_info_list_table */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Creates all the dope vector assignments for a ptr assign from a target*|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void dope_vector_setup(opnd_type	*r_opnd,
                        expr_arg_type	*exp_desc,
 		        opnd_type	*l_opnd,
		        boolean		 ptr_assign)

{
   act_arg_type	a_type;
   int		attr_idx = NULL_IDX;
   opnd_type	base_opnd;
   int		col;
   int          dim = 1;
   int		dope_idx = NULL_IDX;
   int		dv_idx;
   int		dv2_idx;
   int		i;
   int		line;
   int		list_idx;
   int		loc_idx;
   int		max_idx;
   int		mult_idx;
   opnd_type    opnd;
   int		opnd_column;
   int		opnd_line;
   opnd_type	r_dv_opnd;
   int          rank_idx = NULL_IDX;
   int		stride_idx;
   opnd_type	stride_opnd;
#ifdef KEY /* Bug 10177 */
   int		subscript_idx = 0;
#else /* KEY Bug 10177 */
   int		subscript_idx;
#endif /* KEY Bug 10177 */
   boolean      whole_array;


   TRACE (Func_Entry, "dope_vector_setup", NULL);

   /* This routine expects the left operand to be a dope vector */
   /* reference. Either an attr or a Struct_Opr                 */

    find_opnd_line_and_column(l_opnd, &opnd_line, &opnd_column);

# ifdef _DEBUG

   if (OPND_FLD((*l_opnd)) != AT_Tbl_Idx &&
       (OPND_FLD((*l_opnd)) != IR_Tbl_Idx || 
        IR_OPR(OPND_IDX((*l_opnd))) != Struct_Opr)) {
       PRINTMSG(opnd_line, 624, Internal, opnd_column);
   }
# endif
   /********************\
   |* set BASE address *|
   \********************/


   if (! ptr_assign) {
      NTR_IR_TBL(dv_idx);
      IR_OPR(dv_idx) = Dv_Set_Base_Addr;
      IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv_idx) = opnd_line;
      IR_COL_NUM(dv_idx)  = opnd_column;
      COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
      NTR_IR_TBL(loc_idx);
      IR_OPR(loc_idx)  = Loc_Opr;

      if (exp_desc->type == Character) {
         IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
      }
      else {
         IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
      }

      IR_LINE_NUM(loc_idx) = opnd_line;
      IR_COL_NUM(loc_idx)  = opnd_column;

      IR_FLD_R(dv_idx) = IR_Tbl_Idx;
      IR_IDX_R(dv_idx) = loc_idx;
   
      if (exp_desc->rank == 0) {
         COPY_OPND(IR_OPND_L(loc_idx), (*r_opnd));
         just_find_dope_and_rank(r_opnd, &rank_idx, &dope_idx);
      }
      else {
         make_base_subtree(r_opnd, &base_opnd, &rank_idx, &dope_idx);
         COPY_OPND(IR_OPND_L(loc_idx), base_opnd);
      }

# ifdef _TRANSFORM_CHAR_SEQUENCE
# ifdef _TARGET_OS_UNICOS
      if (exp_desc->type == Structure &&
          ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) {

         IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
         COPY_OPND(opnd, IR_OPND_L(loc_idx));
         transform_char_sequence_ref(&opnd, exp_desc->type_idx);
         COPY_OPND(IR_OPND_L(loc_idx), opnd);
      }
# endif
# endif

      gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
                   FALSE, FALSE, TRUE);

      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   }
   else {
      just_find_dope_and_rank(r_opnd, &rank_idx, &dope_idx);
   }



   /*************************\
   |* check for whole array *|
   \*************************/

   if (rank_idx != NULL_IDX) {
      attr_idx      = find_base_attr(&IR_OPND_L(rank_idx), &line, &col);

      if (ATD_IM_A_DOPE(attr_idx)) {
         COPY_OPND(r_dv_opnd, IR_OPND_L(IR_IDX_L(rank_idx)));
      }
      subscript_idx = IR_IDX_R(rank_idx);
   }
   else if (exp_desc->rank != 0)              {
      attr_idx    = find_base_attr(r_opnd, &line, &col);
 
      if (ATD_IM_A_DOPE(attr_idx)) {
         COPY_OPND(r_dv_opnd, IR_OPND_L(OPND_IDX((*r_opnd))));
      }
   }
   else {
      find_opnd_line_and_column(r_opnd, &line, &col);
   }

   if (exp_desc->rank > 0 &&
       ! exp_desc->section) {

      whole_array = TRUE;
   }
   else {
      whole_array = FALSE;
   }

   /*************************\
   |* set the a_contig flag *|
   \*************************/

   a_type = get_act_arg_type(exp_desc);

   if (a_type == Array_Ptr ||
       a_type == Array_Tmp_Ptr ||
       a_type == Whole_Ass_Shape ||
       a_type == Dv_Contig_Section) {

      NTR_IR_TBL(dv_idx);
      IR_OPR(dv_idx) = Dv_Set_A_Contig;
      IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv_idx) = opnd_line;
      IR_COL_NUM(dv_idx)  = opnd_column;
      COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));

      NTR_IR_TBL(dv2_idx);
      IR_OPR(dv2_idx) = Dv_Access_A_Contig;
      IR_TYPE_IDX(dv2_idx)   = CG_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv2_idx) = opnd_line;
      IR_COL_NUM(dv2_idx)  = opnd_column;
      COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
      IR_FLD_R(dv_idx) = IR_Tbl_Idx;
      IR_IDX_R(dv_idx) = dv2_idx;

      gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
                      FALSE, FALSE, TRUE);

      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   }
   else if (a_type == Whole_Allocatable ||
            a_type == Whole_Tmp_Allocatable ||
            a_type == Whole_Sequence ||
            a_type == Whole_Tmp_Sequence ||
            a_type == Whole_Array_Constant ||
            a_type == Contig_Section) {

      NTR_IR_TBL(dv_idx);
      IR_OPR(dv_idx) = Dv_Set_A_Contig;
      IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv_idx) = opnd_line;
      IR_COL_NUM(dv_idx)  = opnd_column;
      COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
      IR_FLD_R(dv_idx) = CN_Tbl_Idx;
      IR_IDX_R(dv_idx) = CN_INTEGER_ONE_IDX;
      IR_LINE_NUM_R(dv_idx) = opnd_line;
      IR_COL_NUM_R(dv_idx)  = opnd_column;

      gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
                      FALSE, FALSE, TRUE);

      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
   }
   else {
      NTR_IR_TBL(dv_idx);
      IR_OPR(dv_idx) = Dv_Set_A_Contig;
      IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv_idx) = opnd_line;
      IR_COL_NUM(dv_idx)  = opnd_column;
      COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
      IR_FLD_R(dv_idx) = CN_Tbl_Idx;
      IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX;
      IR_LINE_NUM_R(dv_idx) = opnd_line;
      IR_COL_NUM_R(dv_idx)  = opnd_column;

      gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
                      FALSE, FALSE, TRUE);

      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
   }
        
   /******************\
   |* set ASSOC flag *|
   \******************/

   NTR_IR_TBL(dv_idx);
   IR_OPR(dv_idx) = Dv_Set_Assoc;
   IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(dv_idx) = opnd_line;
   IR_COL_NUM(dv_idx)  = opnd_column;
   COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
   IR_FLD_R(dv_idx) = CN_Tbl_Idx;
   IR_IDX_R(dv_idx) = CN_INTEGER_ONE_IDX;
   IR_LINE_NUM_R(dv_idx) = opnd_line;
   IR_COL_NUM_R(dv_idx)  = opnd_column;

   gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
                   FALSE, FALSE, TRUE);

   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;


   for (i = 1; i <= exp_desc->rank; i++) {

      /************************************\
      |* set LOW_BOUND for each dimension *|
      \************************************/

      NTR_IR_TBL(dv_idx);
      IR_OPR(dv_idx) = Dv_Set_Low_Bound;
      IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv_idx) = opnd_line;
      IR_COL_NUM(dv_idx)  = opnd_column;
      COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));

      if (whole_array) {
         /* need arrays low bound */
         if (ATD_IM_A_DOPE(attr_idx) &&
             BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) != Assumed_Shape) {
            NTR_IR_TBL(dv2_idx);
            IR_OPR(dv2_idx)    = Dv_Access_Low_Bound;
            IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE;
            IR_LINE_NUM(dv2_idx) = opnd_line;
            IR_COL_NUM(dv2_idx)  = opnd_column;
            COPY_OPND(IR_OPND_L(dv2_idx), r_dv_opnd);
            IR_DV_DIM(dv2_idx) = i;
            IR_FLD_R(dv_idx)   = IR_Tbl_Idx;
            IR_IDX_R(dv_idx)   = dv2_idx;
         }
         else {
            IR_FLD_R(dv_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx), i);
            IR_IDX_R(dv_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx), i);
            IR_LINE_NUM_R(dv_idx) = opnd_line;
            IR_COL_NUM_R(dv_idx)  = opnd_column;

            if (IR_FLD_R(dv_idx) == AT_Tbl_Idx) {
               ADD_TMP_TO_SHARED_LIST(IR_IDX_R(dv_idx));
            }
         }
      }
      else {
         /* set to one */
         IR_FLD_R(dv_idx) = CN_Tbl_Idx;
         IR_IDX_R(dv_idx) = CN_INTEGER_ONE_IDX;
         IR_LINE_NUM_R(dv_idx) = opnd_line;
         IR_COL_NUM_R(dv_idx)  = opnd_column;
      }

      IR_DV_DIM(dv_idx) = i;

      gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
                   FALSE, FALSE, TRUE);

      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;


      /*********************************\
      |* set EXTENT for each dimension *|
      \*********************************/

      NTR_IR_TBL(dv_idx);
      IR_OPR(dv_idx) = Dv_Set_Extent;
      IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv_idx) = opnd_line;
      IR_COL_NUM(dv_idx)  = opnd_column;
      COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));

      NTR_IR_TBL(max_idx);
      IR_OPR(max_idx) = Max_Opr;
      IR_TYPE_IDX(max_idx) = CG_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(max_idx) = opnd_line;
      IR_COL_NUM(max_idx)  = opnd_column;

      NTR_IR_LIST_TBL(list_idx);
      IR_FLD_L(max_idx) = IL_Tbl_Idx;
      IR_LIST_CNT_L(max_idx) = 2;
      IR_IDX_L(max_idx) = list_idx;

      IL_FLD(list_idx) = CN_Tbl_Idx;
      IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
      IL_LINE_NUM(list_idx) = opnd_line;
      IL_COL_NUM(list_idx)  = opnd_column;

      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
      list_idx = IL_NEXT_LIST_IDX(list_idx);

      COPY_OPND(IL_OPND(list_idx), exp_desc->shape[i-1]);
      IL_LINE_NUM(list_idx) = opnd_line;
      IL_COL_NUM(list_idx) = opnd_column;
 
      IR_FLD_R(dv_idx) = IR_Tbl_Idx;
      IR_IDX_R(dv_idx) = max_idx;
      
      IR_DV_DIM(dv_idx) = i;

      gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
                   FALSE, FALSE, TRUE);

      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
      
      /**************************************\
      |* set STRIDE_MULT for each dimension *|
      \**************************************/

      NTR_IR_TBL(dv_idx);
      IR_OPR(dv_idx) = Dv_Set_Stride_Mult;
      IR_TYPE_IDX(dv_idx) = SA_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv_idx) = opnd_line;
      IR_COL_NUM(dv_idx)  = opnd_column;
      COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));

      if (whole_array) {

         gen_dv_stride_mult(&stride_opnd,
                             attr_idx,
                            &r_dv_opnd,
                             exp_desc,
                             i,
                             opnd_line,
                             opnd_column);

         COPY_OPND(IR_OPND_R(dv_idx), stride_opnd);
      }
      else {
         while (IL_FLD(subscript_idx) != IR_Tbl_Idx ||
                IR_OPR(IL_IDX(subscript_idx)) != Triplet_Opr) {
            subscript_idx = IL_NEXT_LIST_IDX(subscript_idx);
            dim++;
         }

         gen_dv_stride_mult(&stride_opnd,
                             attr_idx,
                            &r_dv_opnd,
                             exp_desc,
                             dim,
                             opnd_line,
                             opnd_column);

         stride_idx = IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_L(
                                                      IL_IDX(subscript_idx))));
         mult_idx = gen_ir(OPND_FLD(stride_opnd), OPND_IDX(stride_opnd),
                     Mult_Opr, CG_INTEGER_DEFAULT_TYPE, opnd_line, opnd_column,
                           IL_FLD(stride_idx), IL_IDX(stride_idx));

         IR_FLD_R(dv_idx) = IR_Tbl_Idx;;
         IR_IDX_R(dv_idx) = mult_idx;

         subscript_idx = IL_NEXT_LIST_IDX(subscript_idx);
         dim++;
      }

      IR_DV_DIM(dv_idx) = i;

      gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
                   FALSE, FALSE, TRUE);

      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   }

   /*******************\
   |* clear PTR_ALLOC *|
   \*******************/

   NTR_IR_TBL(dv_idx);
   IR_OPR(dv_idx) = Dv_Set_Ptr_Alloc;
   IR_TYPE_IDX(dv_idx)   = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(dv_idx) = opnd_line;
   IR_COL_NUM(dv_idx)  = opnd_column;
   COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));

   if (dope_idx != NULL_IDX) {
      NTR_IR_TBL(dv2_idx);
      IR_OPR(dv2_idx) = Dv_Access_Ptr_Alloc;
      IR_TYPE_IDX(dv2_idx)   = CG_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv2_idx) = opnd_line;
      IR_COL_NUM(dv2_idx)  = opnd_column;
      COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
      IR_FLD_R(dv_idx) = IR_Tbl_Idx;
      IR_IDX_R(dv_idx) = dv2_idx;
   }
   else {
      IR_FLD_R(dv_idx) = CN_Tbl_Idx;
#ifdef KEY /* Bug 4933 */
      /* If RHS of pointer assignment is a dummy argument, we generally
       * lack dope info for the corresponding formal argument which
       * would tell us whether that formal argument was allocated by
       * pointer. It's too late to change our "Fortran ABI" to pass
       * dope information when a dummy is a pointer target.
       * Optimistically assume that it was allocated by pointer so
       * that subsequent "deallocate" doesn't reject it. */
      IR_IDX_R(dv_idx) = (ptr_assign && NULL_IDX == dope_idx &&
	  AT_Tbl_Idx == OPND_FLD((*r_opnd)) &&
	  AT_IS_DARG(OPND_IDX((*r_opnd)))) ?
        CN_INTEGER_ONE_IDX :
	CN_INTEGER_ZERO_IDX;
#else
      IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX;
#endif /* KEY Bug 4933 */
      IR_LINE_NUM_R(dv_idx) = opnd_line;
      IR_COL_NUM_R(dv_idx)  = opnd_column;
   }

   gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
                   FALSE, FALSE, TRUE);

   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   /*******************\
   |* clear ORIG_BASE *|
   \*******************/

   NTR_IR_TBL(dv_idx);
   IR_OPR(dv_idx) = Dv_Set_Orig_Base;
   IR_TYPE_IDX(dv_idx)   = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(dv_idx) = opnd_line;
   IR_COL_NUM(dv_idx)  = opnd_column;
   COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));

   if (dope_idx != NULL_IDX) {
      NTR_IR_TBL(dv2_idx);
      IR_OPR(dv2_idx) = Dv_Access_Orig_Base;
      IR_TYPE_IDX(dv2_idx)   = SA_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv2_idx) = opnd_line;
      IR_COL_NUM(dv2_idx)  = opnd_column;
      COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
      IR_FLD_R(dv_idx) = IR_Tbl_Idx;
      IR_IDX_R(dv_idx) = dv2_idx;
   }
   else {
      IR_FLD_R(dv_idx) = CN_Tbl_Idx;
      IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX;
      IR_LINE_NUM_R(dv_idx) = opnd_line;
      IR_COL_NUM_R(dv_idx)  = opnd_column;
   }

   gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
                   FALSE, FALSE, TRUE);

   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   /*******************\
   |* clear ORIG_SIZE *|
   \*******************/

   NTR_IR_TBL(dv_idx);
   IR_OPR(dv_idx) = Dv_Set_Orig_Size;
   IR_TYPE_IDX(dv_idx)   = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(dv_idx) = opnd_line;
   IR_COL_NUM(dv_idx)  = opnd_column;
   COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));

   if (dope_idx != NULL_IDX) {
      NTR_IR_TBL(dv2_idx);
      IR_OPR(dv2_idx) = Dv_Access_Orig_Size;
      IR_TYPE_IDX(dv2_idx)   = SA_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv2_idx) = opnd_line;
      IR_COL_NUM(dv2_idx)  = opnd_column;
      COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
      IR_FLD_R(dv_idx) = IR_Tbl_Idx;
      IR_IDX_R(dv_idx) = dv2_idx;
   }
   else {
      IR_FLD_R(dv_idx) = CN_Tbl_Idx;
      IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX;
      IR_LINE_NUM_R(dv_idx) = opnd_line;
      IR_COL_NUM_R(dv_idx)  = opnd_column;
   }

   gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
                   FALSE, FALSE, TRUE);

   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   TRACE (Func_Exit, "dope_vector_setup", NULL);

   return;

}  /* dope_vector_setup */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Given the input type, an io type code is assembled.                   *|
|*									      *|
|* Input parameters:							      *|
|*	type_idx - index into type table                                      *|
|*									      *|
|* Output parameters:							      *|
|*	value    - pointer to either a long or a 2 word array of longs.       *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void make_io_type_code(int	     type_idx,   /* BRIANJ */
		       long_type    *value)

{
   long_type	dec_len = 0;
   int          dp_flag = 0;
#ifdef KEY /* Bug 10177 */
   int		dv_type = 0;
#else /* KEY Bug 10177 */
   int		dv_type;
#endif /* KEY Bug 10177 */
   long_type	int_len = 0;
   int		kind_star = 0;

   f90_type_t	*type_code;


   TRACE (Func_Entry, "make_io_type_code", NULL);

   switch(TYP_DESC(type_idx)) {
      case Default_Typed:
         kind_star = DV_DEFAULT_TYPED;
         break;

      case Star_Typed:
         kind_star = DV_STAR_TYPED;
         break;

      case Kind_Typed:
         if (TYP_TYPE(type_idx) == Real &&
             TYP_KIND_DOUBLE(type_idx)) {
            kind_star = DV_KIND_DOUBLE;
         }
         else if (TYP_KIND_CONST(type_idx)) {
            kind_star = DV_KIND_CONST;
         }
         else {
            kind_star = DV_KIND_TYPED;
         }
         break;
   }

# ifndef _TARGET_OS_MAX
   if (TYP_DECLARED_DBL(type_idx) &&
       kind_star == DV_DEFAULT_TYPED) {

      dp_flag = 1;
   }
# endif

   switch (TYP_TYPE(type_idx)) {
      case Typeless:

         /* BRIANJ - These could be long64 type */

         dec_len = (long) TYP_BIT_LEN(type_idx) / TARGET_BYTES_PER_WORD;
         int_len = (long) TYP_BIT_LEN(type_idx);
         dv_type = DV_TYPELESS;

         break;

      case Integer:

         dec_len = (long) TYP_DCL_VALUE(type_idx);
         int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
         dv_type = DV_INTEGER;

         break;

      case Logical:

         dec_len = (long) TYP_DCL_VALUE(type_idx);
         int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
         dv_type = DV_LOGICAL;

         break;

      case Real:

         dec_len = (long) TYP_DCL_VALUE(type_idx);
         int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
         dv_type = DV_REAL;

         break;

      case Complex:

         dec_len = (long) TYP_DCL_VALUE(type_idx);
         int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
         dv_type = DV_COMPLEX;

         break;

      case Character:

         if (kind_star == DV_DEFAULT_TYPED) {
            dec_len = 0;
         }
         else {
            dec_len = 1;
         }
         int_len = 8;
         dv_type = DV_ASCII_CHAR;

         break;

      case Structure:

         if (ATT_CHAR_SEQ(TYP_IDX(type_idx))) {
            dv_type = DV_ASCII_CHAR_SEQUENCE_STRUCT;
         }
         else {
            dv_type = DV_STRUCT;
         }

         break;

      case CRI_Ptr:
      case CRI_Ch_Ptr:

         int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
         dv_type = DV_INTEGER;

         break;
   }

# ifdef _TYPE_CODE_64_BIT
   type_code = (f90_type_t *)value;

   type_code->unused = 0;
   type_code->type = dv_type;
   type_code->dpflag = dp_flag;
   type_code->kind_or_star = kind_star;
   type_code->int_len = int_len;
   type_code->dec_len = dec_len;
# else

   *value = ((dv_type   << DV_TYPE_SHIFT)         |
             (dp_flag   << DV_DP_SHIFT)           |
             (kind_star << DV_KIND_STAR_SHIFT)  |
             (int_len   << DV_INT_LEN_SHIFT)      |
             (dec_len   << DV_DEC_LEN_SHIFT));
# endif

   TRACE (Func_Exit, "make_io_type_code", NULL);

   return;

}  /* make_io_type_code */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This routine creates a constant table entry for a dope vector type    *|
|*      code.                                                                 *|
|*									      *|
|* Input parameters:							      *|
|*	attr_idx - index for attr.                                            *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	constant table idx for type code.                                     *|
|*									      *|
\******************************************************************************/

static int create_dv_type_code(int	attr_idx)

{
   int		constant_idx = NULL_IDX;
   long_type    constant[2];

   TRACE (Func_Entry, "create_dv_type_code", NULL);

   make_io_type_code(ATD_TYPE_IDX(attr_idx), constant);

   constant_idx = ntr_const_tbl(IO_TYPE_CODE_TYPE, FALSE, constant);

   TRACE (Func_Exit, "create_dv_type_code", NULL);

   return(constant_idx);

}  /* create_dv_type_code */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void gen_common_dv_init(opnd_type            *dv_opnd,
                        int                  dv_attr_idx,
                        sh_position_type     position)

{
   int          	col;
   int			ir_idx;
   size_offset_type	length;
   int			line;
   int			mult_idx;
   size_offset_type	result;
   int          	type_idx;


   TRACE (Func_Entry, "gen_common_dv_init", NULL);

   find_opnd_line_and_column(dv_opnd, &line, &col);

   /*************\
   |* BASE ADDR *|
   \*************/

   /* Do not set */

   /*************\
   |* EL_LEN    *|
   \*************/

   NTR_IR_TBL(ir_idx);
   IR_OPR(ir_idx) = Dv_Set_El_Len;
   IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(ir_idx) = line;
   IR_COL_NUM(ir_idx) = col;

   COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));

   type_idx = ATD_TYPE_IDX(dv_attr_idx);

   if (TYP_TYPE(type_idx) == Structure) {
      IR_FLD_R(ir_idx)	= (fld_type) ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
      IR_IDX_R(ir_idx)	= ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
      IR_LINE_NUM_R(ir_idx)	= line;
      IR_COL_NUM_R(ir_idx)	= col;
   }
   else if (TYP_TYPE(type_idx) == Character) {

      IR_FLD_R(ir_idx)      = TYP_FLD(type_idx);
      IR_IDX_R(ir_idx)      = TYP_IDX(type_idx);
      IR_LINE_NUM_R(ir_idx) = line;
      IR_COL_NUM_R(ir_idx)  = col;

      if (IR_FLD_R(ir_idx) == AT_Tbl_Idx) {
         ADD_TMP_TO_SHARED_LIST(IR_IDX_R(ir_idx));
      }

      if (! char_len_in_bytes) {

         /* Len is in bytes on solaris */
         /* Len is in bits for everyone else */

         if (TYP_FLD(type_idx) == CN_Tbl_Idx) {
            result.fld		= CN_Tbl_Idx;
            result.idx		= CN_INTEGER_CHAR_BIT_IDX;
            length.fld		= TYP_FLD(type_idx);
            length.idx		= TYP_IDX(type_idx);

            size_offset_binary_calc(&length,
                                    &result,
                                     Mult_Opr,
                                    &result);

            if (result.fld == NO_Tbl_Idx) {
               IR_FLD_R(ir_idx)       = CN_Tbl_Idx;
               IR_IDX_R(ir_idx)       = ntr_const_tbl(result.type_idx,
                                                      FALSE,
                                                      result.constant);
            }
            else {
               IR_FLD_R(ir_idx)       = result.fld;
               IR_IDX_R(ir_idx)       = result.idx;
            }

            IR_LINE_NUM_R(ir_idx) = line;
            IR_COL_NUM_R(ir_idx)  = col;
         }
         else {
            NTR_IR_TBL(mult_idx);
            IR_OPR(mult_idx) = Mult_Opr;
            IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
            IR_LINE_NUM(mult_idx) = line;
            IR_COL_NUM(mult_idx)  = col;
            IR_FLD_L(mult_idx)    = CN_Tbl_Idx;
            IR_IDX_L(mult_idx)    = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8);
            IR_LINE_NUM_L(mult_idx) = line;
            IR_COL_NUM_L(mult_idx)  = col;

            IR_FLD_R(mult_idx)    = TYP_FLD(type_idx);
            IR_IDX_R(mult_idx)    = TYP_IDX(type_idx);
            IR_LINE_NUM_R(mult_idx) = line;
            IR_COL_NUM_R(mult_idx)  = col;

            IR_FLD_R(ir_idx)      = IR_Tbl_Idx;
            IR_IDX_R(ir_idx)      = mult_idx;
         }
      }
   }
   else {
      IR_FLD_R(ir_idx) = CN_Tbl_Idx;
      IR_IDX_R(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
                                  storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
      IR_LINE_NUM_R(ir_idx) = line;
      IR_COL_NUM_R(ir_idx)  = col;
   }

   gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   if (position == After) {
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
   }
   else {
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
   }



   /*************\
   |* ASSOC     *|
   \*************/

   /* Do not set */

   /*************\
   |* PTR_ALLOC *|
   \*************/

   /* Do not set */

   /*************\
   |* P_OR_A    *|
   \*************/

   NTR_IR_TBL(ir_idx);
   IR_OPR(ir_idx) = Dv_Set_P_Or_A;
   IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(ir_idx) = line;
   IR_COL_NUM(ir_idx) = col;

   COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));

   IR_FLD_R(ir_idx) = CN_Tbl_Idx;

   if (ATD_ALLOCATABLE(dv_attr_idx)) {
      IR_IDX_R(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 2);
   }
   else if (ATD_POINTER(dv_attr_idx)) {
      IR_IDX_R(ir_idx) = CN_INTEGER_ONE_IDX;
   }
   else {
      IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX;
   }
   IR_LINE_NUM_R(ir_idx) = line;
   IR_COL_NUM_R(ir_idx)  = col;

   gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   if (position == After) {
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
   }
   else {
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
   }


   /*************\
   |* A_CONTIG  *|
   \*************/

   /* if it is in common block, this bit is left untouched */
   if (!ATD_IN_COMMON(dv_attr_idx))
   {
   NTR_IR_TBL(ir_idx);
   IR_OPR(ir_idx) = Dv_Set_A_Contig;
   IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(ir_idx) = line;
   IR_COL_NUM(ir_idx) = col;

   COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));

   IR_FLD_R(ir_idx) = CN_Tbl_Idx;

   if (ATD_ALLOCATABLE(dv_attr_idx)) {
      IR_IDX_R(ir_idx) = CN_INTEGER_ONE_IDX;
   }
   else {
      IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX;
   }
   IR_LINE_NUM_R(ir_idx) = line;
   IR_COL_NUM_R(ir_idx)  = col;

   gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   if (position == After) {
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
   }
   else {
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
   }
   }


   /*************\
   |* N_DIM     *|
   \*************/

   NTR_IR_TBL(ir_idx);
   IR_OPR(ir_idx) =Dv_Set_N_Dim ;
   IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(ir_idx) = line;
   IR_COL_NUM(ir_idx) = col;

   COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));

   IR_FLD_R(ir_idx) = CN_Tbl_Idx;
   IR_IDX_R(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
                                  (ATD_ARRAY_IDX(dv_attr_idx) ? 
                                   BD_RANK(ATD_ARRAY_IDX(dv_attr_idx)) : 0));
   IR_LINE_NUM_R(ir_idx) = line;
   IR_COL_NUM_R(ir_idx)  = col;

   gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   if (position == After) {
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
   }
   else {
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
   }


   /*************\
   |* TYPE_CODE *|
   \*************/

   NTR_IR_TBL(ir_idx);
   IR_OPR(ir_idx) = Dv_Set_Typ_Code;
   IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(ir_idx) = line;
   IR_COL_NUM(ir_idx) = col;

   COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));

   IR_FLD_R(ir_idx) = CN_Tbl_Idx;
   IR_IDX_R(ir_idx) = create_dv_type_code(dv_attr_idx);
   IR_LINE_NUM_R(ir_idx) = line;
   IR_COL_NUM_R(ir_idx)  = col;

   gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   if (position == After) {
      SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
   }
   else {
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
   }


   /*************\
   |* ORIG_BASE *|
   \*************/

   /* Do not set */

   /*************\
   |* ORIG_SIZE *|
   \*************/

   /* Do not set */

   TRACE (Func_Exit, "gen_common_dv_init", NULL);

   return;

}  /* gen_common_dv_init */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Create a whole def of a dope vector that is in a module block.        *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void gen_static_dv_whole_def(opnd_type         *dv_opnd,
                             int                attr_idx,
			     sh_position_type	position)

{
   int          	col;
   long_type		constant[2];
   int			const_idx;
   ext_dope_type	*dv_ptr;
   int			ir_idx;
   int			i;
   int          	line;
   int			mult_idx;
   int			num_words;
   long_type         	rank;  /* BRIANJ */
   int                  type_idx;


   TRACE (Func_Entry, "gen_static_dv_whole_def", NULL);

   find_opnd_line_and_column(dv_opnd, &line, &col);

   rank	= (ATD_ARRAY_IDX(attr_idx) ? (long)BD_RANK(ATD_ARRAY_IDX(attr_idx)) :0);

   num_words	= DV_HD_WORD_SIZE + (rank * DV_DIM_WORD_SIZE);

   CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
   TYP_TYPE(TYP_WORK_IDX)	= Typeless;
   TYP_BIT_LEN(TYP_WORK_IDX)	= num_words * TARGET_BITS_PER_WORD;
   type_idx			= ntr_type_tbl();

   const_idx	= ntr_const_tbl(type_idx, FALSE, NULL);

   /* NULL() intrinsic */
   if (ATD_CLASS(attr_idx) == Compiler_Tmp) {
      ATD_FLD(attr_idx) = CN_Tbl_Idx;
      ATD_TMP_IDX(attr_idx) = const_idx;
      ATD_TMP_INIT_NOT_DONE(attr_idx) = TRUE;
   }
   else {
      gen_init_stmt(dv_opnd,
                    const_idx,
                    position);
   }

   dv_ptr = (ext_dope_type *)&CN_CONST(const_idx);
   type_idx = ATD_TYPE_IDX(attr_idx);

   /* the entire constant is initialized to 0's */
   /* so just fill in the non zero parts.       */

   /*************\
   |* EL_LEN    *|
   \*************/

   if (TYP_TYPE(type_idx) == Structure) {

      if (compare_cn_and_value(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)),
                               MAX_DV_EL_LEN,
                               Ge_Opr)) {
         PRINTMSG(line, 1174, Error, col,
                  CN_INT_TO_C(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx))),
                  MAX_DV_EL_LEN);
         DV_SET_EL_LEN(*dv_ptr, MAX_DV_EL_LEN);
      }
      else {  /* BRIANJ */
         DV_SET_EL_LEN(*dv_ptr,
                CN_INT_TO_C(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx))));
      }
   }
   else if (TYP_TYPE(type_idx) == Character) {

      if (TYP_FLD(type_idx) == CN_Tbl_Idx) {

         if (char_len_in_bytes) {

            if (compare_cn_and_value(TYP_IDX(type_idx),
                                     MAX_DV_EL_LEN,
                                     Ge_Opr)) {
               PRINTMSG(line, 1174, Error, col, 
                        CN_INT_TO_C(TYP_IDX(type_idx)),
                        MAX_DV_EL_LEN);
               DV_SET_EL_LEN(*dv_ptr, MAX_DV_EL_LEN);
            }
            else {  /* BRIANJ */
               DV_SET_EL_LEN(*dv_ptr, CN_INT_TO_C(TYP_IDX(type_idx)));
            }
         }
         else {

            if (compare_cn_and_value(TYP_IDX(type_idx),
                                     MAX_DV_EL_LEN/8,
                                     Ge_Opr)) {
               PRINTMSG(line, 1174, Error, col, 
                        CN_INT_TO_C(TYP_IDX(type_idx)),
                        MAX_DV_EL_LEN/8);
               DV_SET_EL_LEN(*dv_ptr, MAX_DV_EL_LEN);
            }
            else {  /* BRIANJ */
               DV_SET_EL_LEN(*dv_ptr, CN_INT_TO_C(TYP_IDX(type_idx)) * 8);
            }
         }
      }
      else {
         /* We are here only for variable length char pointers */
         /* They cannot be inside a derived type, so just generate */
         /* an assignment statement to fill in the length at runtime. */

         NTR_IR_TBL(ir_idx);
         IR_OPR(ir_idx) = Dv_Set_El_Len;
         IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
         IR_LINE_NUM(ir_idx) = line;
         IR_COL_NUM(ir_idx) = col;

         COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));

         if (char_len_in_bytes) {

            /* Len is in bytes for solaris */
            IR_FLD_R(ir_idx)      = TYP_FLD(type_idx);
            IR_IDX_R(ir_idx)      = TYP_IDX(type_idx);
            IR_LINE_NUM_R(ir_idx) = line;
            IR_COL_NUM_R(ir_idx)  = col;
         }
         else {
            NTR_IR_TBL(mult_idx);
            IR_OPR(mult_idx) = Mult_Opr;
            IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
            IR_LINE_NUM(mult_idx) = line;
            IR_COL_NUM(mult_idx)  = col;
            IR_FLD_L(mult_idx)    = CN_Tbl_Idx;
            IR_IDX_L(mult_idx)    = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8);
            IR_LINE_NUM_L(mult_idx) = line;
            IR_COL_NUM_L(mult_idx)  = col;

            IR_FLD_R(mult_idx)    = TYP_FLD(type_idx);
            IR_IDX_R(mult_idx)    = TYP_IDX(type_idx);
            IR_LINE_NUM_R(mult_idx) = line;
            IR_COL_NUM_R(mult_idx)  = col;

            IR_FLD_R(ir_idx)      = IR_Tbl_Idx;
            IR_IDX_R(ir_idx)      = mult_idx;
         }

         gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

         if (position == After) {
            SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
            SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
         }
         else {
            SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
            SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
         }
      }
   }
   else {
      DV_SET_EL_LEN(*dv_ptr, storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
   }

   /*************\
   |* P_OR_A    *|
   \*************/

   if (ATD_ALLOCATABLE(attr_idx)) {
      DV_SET_P_OR_A(*dv_ptr, 2);
   }
   else if (ATD_POINTER(attr_idx)) {
      DV_SET_P_OR_A(*dv_ptr, 1);
   }

   /*************\
   |* N_DIM     *|
   \*************/

   DV_SET_NUM_DIMS(*dv_ptr, rank);

   /*************\
   |* TYPE_CODE *|
   \*************/

   make_io_type_code(type_idx, constant);
# ifdef _TYPE_CODE_64_BIT
   DV_SET_TYPE_CODE(*dv_ptr, *(f90_type_t *)constant);
# else
   DV_SET_TYPE_CODE(*dv_ptr, *constant);
# endif

   if (cmd_line_flags.runtime_bounds &&
       ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {

      for (i = 0; i < BD_RANK(ATD_ARRAY_IDX(attr_idx)); i++) {

         /************************************\
         |* set LOW_BOUND for each dimension *|
         \************************************/

         DV_SET_LOW_BOUND(*dv_ptr, i, 1);

         /*********************************\
         |* set EXTENT for each dimension *|
         \*********************************/

         /* leave as zero */

         /**************************************\
         |* set STRIDE_MULT for each dimension *|
         \**************************************/

         DV_SET_STRIDE_MULT(*dv_ptr, i, 1);

      }
   }

#ifdef KEY /* Bug 9608 */
   /*
    * When we set assoc=0 for an array, we also set contig=1 so that
    * copyinout doesn't blow up if user (illegally) passes the null
    * pointer to a procedure lacking an explicit interface, in the
    * (unjustified) expectation that the pointer won't be
    * dereferenced if the procedure doesn't refer to the dummy
    * argument. This seems cheaper than adding a test for null
    * before and after every call.
    */
   if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX && !DV_ASSOC(*dv_ptr)) {
     DV_SET_A_CONTIG(*dv_ptr, 1);
   }
#endif /* KEY Bug 9608 */

   TRACE (Func_Exit, "gen_static_dv_whole_def", NULL);

   return;

}  /* gen_static_dv_whole_def */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

static long64 create_imp_do_loops(opnd_type	*top_opnd)

{

   int			col;
   long64		count = 1;
   long64		end;
   int			i;
   int			imp_idx;	
   int			line;
   int			list_idx;
   opnd_type		opnd;
   long64		start;
   int			tmp_idx;
   int			trip_list_idx;


   TRACE (Func_Entry, "create_imp_do_loops", NULL);

   COPY_OPND(opnd, (*top_opnd));
   find_opnd_line_and_column(&opnd, &line, &col);

   while (OPND_FLD(opnd) == IR_Tbl_Idx) {

      if (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) {

         trip_list_idx = IR_IDX_R(OPND_IDX(opnd));

         for (i = 0; i < IR_LIST_CNT_R(OPND_IDX(opnd)); i++) {

            NTR_IR_TBL(imp_idx);
            IR_OPR(imp_idx)        = Implied_Do_Opr;
            IR_TYPE_IDX(imp_idx)   = TYPELESS_DEFAULT_TYPE;
            IR_LINE_NUM(imp_idx)   = line;
            IR_COL_NUM(imp_idx)    = col;

            NTR_IR_LIST_TBL(list_idx);
            IR_FLD_L(imp_idx)      = IL_Tbl_Idx;
            IR_LIST_CNT_L(imp_idx) = 1;
            IR_IDX_L(imp_idx)      = list_idx;

            COPY_OPND(IL_OPND(list_idx), (*top_opnd));
            OPND_FLD((*top_opnd)) = IR_Tbl_Idx;
            OPND_IDX((*top_opnd)) = imp_idx;

            /* create the tmp implied do control variable. */

            tmp_idx                   = gen_compiler_tmp(line, col, Priv, TRUE);
            ATD_TYPE_IDX(tmp_idx)     = CG_INTEGER_DEFAULT_TYPE;
            AT_SEMANTICS_DONE(tmp_idx)= TRUE;
            ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
            ATD_IMP_DO_LCV(tmp_idx)   = TRUE;
            ATD_LCV_IS_CONST(tmp_idx) = TRUE;

            /* hook in control var. */

            NTR_IR_LIST_TBL(list_idx);
            IR_FLD_R(imp_idx)      = IL_Tbl_Idx;
            IR_LIST_CNT_R(imp_idx) = 4;
            IR_IDX_R(imp_idx)      = list_idx;

            IL_FLD(list_idx)   = AT_Tbl_Idx;
            IL_IDX(list_idx)   = tmp_idx;
            IL_LINE_NUM(list_idx) = line;
            IL_COL_NUM(list_idx)  = col;

            /* second is start opnd */

            NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
            IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
            list_idx = IL_NEXT_LIST_IDX(list_idx);

            COPY_OPND(IL_OPND(list_idx),
                      IL_OPND(IR_IDX_L(IL_IDX(trip_list_idx))));

            start = CN_INT_TO_C(IL_IDX(list_idx));

            /* third is end opnd */

            NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
            IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
            list_idx = IL_NEXT_LIST_IDX(list_idx);

            COPY_OPND(IL_OPND(list_idx),
                      IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_L(
                               IL_IDX(trip_list_idx)))));

            end = CN_INT_TO_C(IL_IDX(list_idx));

            count = count * ((end - start) + 1);

            /* fourth is stride opnd */

            NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
            IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
            list_idx = IL_NEXT_LIST_IDX(list_idx);

            COPY_OPND(IL_OPND(list_idx),
                      IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(
                                    IR_IDX_L(IL_IDX(trip_list_idx))))));


            /* replace triplet with tmp control variable */

            IL_FLD(trip_list_idx) = AT_Tbl_Idx;
            IL_IDX(trip_list_idx) = tmp_idx;
            IL_LINE_NUM(trip_list_idx) = line;
            IL_COL_NUM(trip_list_idx)  = col;

            trip_list_idx = IL_NEXT_LIST_IDX(trip_list_idx);
         }
      }

      COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
   }


   TRACE (Func_Exit, "create_imp_do_loops", NULL);

   return(count);

}  /* create_imp_do_loops */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This routine creates a chain of stmts to initialize a dope vector     *|
|*      or a structure with pointers.                                         *|
|*									      *|
|* Input parameters:							      *|
|*	attr_idx - idx of variable to process.                                *|
|*									      *|
|* Output parameters:							      *|
|*      exit_sh_idx - exit code chain if needed.                              *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void gen_entry_dope_code(int	 attr_idx)

{
   expr_arg_type exp_desc;
   void          (*func)();
   opnd_type     opnd;
   int		 opr;


   TRACE (Func_Entry, "gen_entry_dope_code", NULL);

   if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) {
      func = gen_static_dv_whole_def;
      opr = Init_Opr;
   }
   else if (ATD_AUTOMATIC(attr_idx) ||
            ATD_CLASS(attr_idx) == Function_Result) {
      func = gen_dv_whole_def_init;
      opr = Asg_Opr;
   }
   else if (ATD_IN_COMMON(attr_idx)) {

# if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
      func = gen_common_dv_init;
      opr = Init_Opr;
# else
      func = gen_static_dv_whole_def;
      opr = Init_Opr;
# endif
   }
   else if (ATD_SAVED(attr_idx) ||
#ifdef KEY /* Bug 10467 */
            ATD_DATA_INIT(attr_idx) ||
#endif /* KEY Bug 10467 */
            ATP_SAVE_ALL(SCP_ATTR_IDX(curr_scp_idx))) {
      func = gen_static_dv_whole_def;
      opr = Init_Opr;
   }
   else {
      func = gen_dv_whole_def_init;
      opr = Asg_Opr;
   }

   if (AT_DCL_ERR(attr_idx)) {
      goto EXIT;
   }

# if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))

   if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module &&
       ATD_IN_COMMON(attr_idx)) {

      /* intentionally blank. We can't initialize common block */
      /* dope vectors from multiple .o's on solaris.           */
   }
   else 
# endif
   if (ATD_IM_A_DOPE(attr_idx)) {
      OPND_FLD(opnd) = AT_Tbl_Idx;
      OPND_IDX(opnd) = attr_idx;
      OPND_LINE_NUM(opnd) = SH_GLB_LINE(curr_stmt_sh_idx);
      OPND_COL_NUM(opnd)  = SH_COL_NUM(curr_stmt_sh_idx);
      (*func)(&opnd, attr_idx, After);
   }
   else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure           &&
            (ATT_POINTER_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx))) ||
#ifdef KEY /* Bug 6845 */
            ATT_ALLOCATABLE_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx))) ||
#endif /* KEY Bug 6845 */
             ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx))))  &&
            ! AT_DCL_ERR(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {

      OPND_FLD(opnd)      = AT_Tbl_Idx;
      OPND_IDX(opnd)      = attr_idx;
      OPND_LINE_NUM(opnd) = SH_GLB_LINE(curr_stmt_sh_idx);
      OPND_COL_NUM(opnd)  = SH_COL_NUM(curr_stmt_sh_idx);

# if defined(_TARGET_OS_MAX)
      if (ATD_ARRAY_IDX(attr_idx) ||
          ATD_PE_ARRAY_IDX(attr_idx))
# else
      if (ATD_ARRAY_IDX(attr_idx))
# endif
                                    {
         gen_whole_subscript(&opnd, &exp_desc);
      }

      process_cpnt_inits(&opnd, 
                         TYP_IDX(ATD_TYPE_IDX(attr_idx)),
                         func,
			 opr,
                         After);
   }

EXIT:

   TRACE (Func_Exit, "gen_entry_dope_code", NULL);

   return;

}  /* gen_entry_dope_code */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	recursively go through all components of a structure to look for      *|
|*      pointers. Then call the supplied routine func for processing.         *|
|*									      *|
|* Input parameters:							      *|
|*	left_opnd - current base of sub-object reference.                     *|
|*      type_idx  - defined type attr.                                        *|
|*      func      - function to call for processing.                          *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/


void process_cpnt_inits(opnd_type  	*left_opnd,
			int        	type_idx,
			void	  	(*func)(),
			int		opr,
			sh_position_type	position)

{
   int		 attr_idx;
   opnd_type	 cn_opnd;
   int		 col;
#ifdef KEY /* Bug 10177 */
   int		 const_idx = 0;
#else /* KEY Bug 10177 */
   int		 const_idx;
#endif /* KEY Bug 10177 */
   expr_arg_type exp_desc;
   int		 i;
   int		 init_idx;
   int		 ir_idx;
   int		 line;
   int		 list_idx;
   boolean	 need_loops = FALSE;
   opnd_type     opnd;
   int           placeholder_sh_idx = NULL_IDX;
   int           save_curr_stmt_sh_idx;
   int		 save_target_array_idx;
   int		 sub_idx;
   int		 sn_idx;
   int		 tmp_idx;
   opnd_type	 tmp_opnd;

   TRACE (Func_Entry, "process_cpnt_inits", NULL);

   find_opnd_line_and_column(left_opnd, &line, &col);

# ifdef _DEBUG
   if (opr != Asg_Opr &&
       opr != Init_Opr) {
      PRINTMSG(line, 626, Internal, col,
               "Asg_Opr or Init_Opr", "process_cpnt_inits");
   }
# endif

   save_curr_stmt_sh_idx = curr_stmt_sh_idx;

   if (position == After) {
      save_curr_stmt_sh_idx = SH_NEXT_IDX(save_curr_stmt_sh_idx);
   }

# if defined(_GEN_LOOPS_FOR_DV_WHOLE_DEF)
   if (func == (void (*)())gen_dv_whole_def_init ||
       func == (void (*)())gen_dv_whole_def ||
       func == (void (*)())gen_sf_dv_whole_def) {

      need_loops = TRUE;
   }
# endif

   if (ATT_DEFAULT_INITIALIZED(type_idx) &&
       opr == Asg_Opr) {
      need_loops = TRUE;
   }

   if (need_loops) {
      gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

      if (position == Before) {
         curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
      }
      placeholder_sh_idx = curr_stmt_sh_idx;

      gen_dv_def_loops(left_opnd);

# ifdef _DEBUG
      if (placeholder_sh_idx != curr_stmt_sh_idx) {
         PRINTMSG(line, 626, Internal, col,
                  "placeholder_sh_idx == curr_stmt_sh_idx",
                  "process_cpnt_inits");
      }
# endif
   }

   sn_idx = ATT_FIRST_CPNT_IDX(type_idx);

   while (sn_idx != NULL_IDX) {
      attr_idx = SN_ATTR_IDX(sn_idx);

#ifdef KEY /* Bug 6845 */
      if (ATD_ALLOCATABLE(attr_idx) ||
	  (ATD_POINTER(attr_idx) &&
	   TYP_LINEAR(ATD_TYPE_IDX(attr_idx)) != Proc_Ptr))
#else /* KEY Bug 6845 */
      if (ATD_POINTER(attr_idx))
#endif /* KEY Bug 6845 */
      {
         NTR_IR_TBL(ir_idx);
         IR_OPR(ir_idx) = Struct_Opr;
         IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
         IR_LINE_NUM(ir_idx) = line;
         IR_COL_NUM(ir_idx)  = col;
         COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));
         IR_FLD_R(ir_idx) = AT_Tbl_Idx;
         IR_IDX_R(ir_idx) = attr_idx;
         IR_LINE_NUM_R(ir_idx) = line;
         IR_COL_NUM_R(ir_idx)  = col;
         OPND_FLD(opnd) = IR_Tbl_Idx;
         OPND_IDX(opnd) = ir_idx;

         if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
             IR_RANK(ir_idx) = IR_RANK(IR_IDX_L(ir_idx));
         }

         (*func)(&opnd, attr_idx, position);
      }
      else if (ATD_CPNT_INIT_IDX(attr_idx) != NULL_IDX) {

         NTR_IR_TBL(ir_idx);

         IR_OPR(ir_idx)         = Struct_Opr;
         IR_TYPE_IDX(ir_idx)    = ATD_TYPE_IDX(attr_idx);
         IR_LINE_NUM(ir_idx)    = line;
         IR_COL_NUM(ir_idx)     = col;

         COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));

         IR_FLD_R(ir_idx)       = AT_Tbl_Idx;
         IR_IDX_R(ir_idx)       = attr_idx;
         IR_LINE_NUM_R(ir_idx)  = line;
         IR_COL_NUM_R(ir_idx)   = col;

         if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
             IR_RANK(ir_idx)    = IR_RANK(IR_IDX_L(ir_idx));
         }

	 gen_opnd(&opnd, ir_idx, IR_Tbl_Idx, line, col);

         if (opr == Asg_Opr) {

            if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
               exp_desc = init_exp_desc;
               gen_whole_subscript(&opnd, &exp_desc);
            }
            else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
               gen_whole_substring(&opnd, 0);
            }

            NTR_IR_TBL(init_idx);

            IR_OPR(init_idx)       = Asg_Opr;
            IR_LINE_NUM(init_idx)  = line;
            IR_COL_NUM(init_idx)   = col;
            IR_TYPE_IDX(init_idx)  = ATD_TYPE_IDX(attr_idx);
            COPY_OPND(IR_OPND_L(init_idx), opnd);
            IR_LINE_NUM_L(init_idx)= line;
            IR_COL_NUM_L(init_idx) = col;


	    if (TYP_LINEAR(ATD_TYPE_IDX(attr_idx)) != Proc_Ptr) {
		IR_IDX_R(init_idx) = ATD_CPNT_INIT_IDX(attr_idx);
		IR_FLD_R(init_idx) = (fld_type) ATD_FLD(attr_idx);

	    } else {
		IR_IDX_R(init_idx) = CN_INTEGER_ZERO_IDX;
		IR_FLD_R(init_idx) = CN_Tbl_Idx;
	    }

	    IR_LINE_NUM_R(init_idx)  = line;
	    IR_COL_NUM_R(init_idx)   = col;
            gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

            if (position == After) {
               SH_IR_IDX(curr_stmt_sh_idx) = init_idx;
               SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
            }
            else {
               SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = init_idx;
               SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
            }
         }
         else {
            /* Init_Opr */

            if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
               NTR_IR_TBL(sub_idx);
               IR_OPR(sub_idx) = Subscript_Opr;
               IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(attr_idx);
               IR_LINE_NUM(sub_idx) = line;
               IR_COL_NUM(sub_idx) = col;

               COPY_OPND(IR_OPND_L(sub_idx), opnd);

               NTR_IR_LIST_TBL(list_idx);
               IR_FLD_R(sub_idx) = IL_Tbl_Idx;
               IR_IDX_R(sub_idx) = list_idx;
               IR_LIST_CNT_R(sub_idx) = 1;

               IL_FLD(list_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx),1);
               IL_IDX(list_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx),1);
               IL_LINE_NUM(list_idx) = line;
               IL_COL_NUM(list_idx) = col;

               for (i = 2; i<= BD_RANK(ATD_ARRAY_IDX(attr_idx)); i++) {
                  NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
                  IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
                  list_idx = IL_NEXT_LIST_IDX(list_idx);

                  IR_LIST_CNT_R(sub_idx) += 1;

                  IL_FLD(list_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx),i);
                  IL_IDX(list_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx),i);
                  IL_LINE_NUM(list_idx) = line;
                  IL_COL_NUM(list_idx) = col;
               }

               gen_opnd(&opnd, sub_idx, IR_Tbl_Idx, line, col);
            }

            if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
               gen_whole_substring(&opnd, 0);
            }

            if (ATD_FLD(attr_idx) != CN_Tbl_Idx) {

               gen_opnd(&tmp_opnd, ATD_CPNT_INIT_IDX(attr_idx),
                        (fld_type) ATD_FLD(attr_idx), line, col);

               tmp_idx = find_left_attr(&tmp_opnd);

	       if (TYP_LINEAR(ATD_TYPE_IDX(attr_idx)) == Proc_Ptr) {
		  const_idx = CN_INTEGER_ZERO_IDX;
		  ATD_CPNT_INIT_IDX(attr_idx) = NULL_IDX;
	       }
	       else if (ATD_FLD(tmp_idx) == CN_Tbl_Idx) {
                  const_idx = ATD_TMP_IDX(tmp_idx);
               }
               else if (ATD_FLD(tmp_idx) == IR_Tbl_Idx &&
                        IR_OPR(ATD_TMP_IDX(tmp_idx)) == Mult_Opr) {
            
                  /* this is a scalar broadcast */
                  /* so broadcast it now. */

                  const_idx = IR_IDX_R(ATD_TMP_IDX(tmp_idx));

                  save_target_array_idx = target_array_idx;
                  target_array_idx = ATD_ARRAY_IDX(attr_idx);

                  exp_desc = init_exp_desc;
                  exp_desc.type_idx = CN_TYPE_IDX(const_idx);
                  exp_desc.type = TYP_TYPE(exp_desc.type_idx);
                  exp_desc.linear_type = TYP_LINEAR(exp_desc.type_idx);
                  exp_desc.constant = TRUE;
                  exp_desc.foldable = TRUE;

                  gen_opnd(&cn_opnd, const_idx, CN_Tbl_Idx, line, col);
                  fold_aggragate_expression(&cn_opnd,
                                            &exp_desc,
                                             TRUE); /* return constant */
                  target_array_idx = save_target_array_idx;

                  const_idx = OPND_IDX(cn_opnd);
               }
            }
            else {
               const_idx = ATD_CPNT_INIT_IDX(attr_idx);
            }

            gen_init_stmt(&opnd,
                          const_idx,
                          position);
         }
      }
      else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure           &&
               (ATT_POINTER_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx))) ||
#ifdef KEY /* Bug 6845 */
               ATT_ALLOCATABLE_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx))) ||
#endif /* KEY Bug 6845 */
                ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx))))) {

         NTR_IR_TBL(ir_idx);
         IR_OPR(ir_idx) = Struct_Opr;
         IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
         IR_LINE_NUM(ir_idx) = line;
         IR_COL_NUM(ir_idx)  = col;
         COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));
         IR_FLD_R(ir_idx) = AT_Tbl_Idx;
         IR_IDX_R(ir_idx) = attr_idx;
         IR_LINE_NUM_R(ir_idx) = line;
         IR_COL_NUM_R(ir_idx)  = col;
         OPND_FLD(opnd) = IR_Tbl_Idx;
         OPND_IDX(opnd) = ir_idx;

         if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
             IR_RANK(ir_idx) = IR_RANK(IR_IDX_L(ir_idx));
         }

         if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
            exp_desc = init_exp_desc;
            gen_whole_subscript(&opnd, &exp_desc);
         }

         process_cpnt_inits(&opnd, 
                            TYP_IDX(ATD_TYPE_IDX(attr_idx)),
                            func,
			    opr,
                            position);

      }

      sn_idx = SN_SIBLING_LINK(sn_idx);
   }

   /* remove placeholder_sh_idx */

   if (placeholder_sh_idx != NULL_IDX) {
      remove_sh(placeholder_sh_idx);
      FREE_SH_NODE(placeholder_sh_idx);
   }

   if (position == Before) {
      curr_stmt_sh_idx = save_curr_stmt_sh_idx;
   }
   else {
      if (save_curr_stmt_sh_idx != NULL_IDX) {
         curr_stmt_sh_idx = SH_PREV_IDX(save_curr_stmt_sh_idx);
      }
      else {
         /* find end of stmts */
          while (SH_NEXT_IDX(curr_stmt_sh_idx) != NULL_IDX) {
            curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
         }
      }
   }

   TRACE (Func_Exit, "process_cpnt_inits", NULL);

   return;

}  /* process_cpnt_inits */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

static void gen_init_stmt(opnd_type		*left_opnd,
                          int			const_idx,
                          sh_position_type	position)

{
   int                  array_attr_idx;
   opnd_type            base_opnd;
   int                  bd_idx;
   int                  col;
   long64               count = 0;
   int                  init_idx;
   int                  line;
   int                  list_idx;
   int                  mult_idx;
   int                  num_loops = 0;
   opnd_type            opnd;
   int                  rank_idx = NULL_IDX;
   long_type            result[MAX_WORDS_FOR_INTEGER];
   long64	        sm_bits;
   int                  type_idx;
   int                  unused = NULL_IDX;
   int                  unused2;
   long_type            the_constant[MAX_WORDS_FOR_INTEGER];


   TRACE (Func_Entry, "gen_init_stmt", NULL);

   find_opnd_line_and_column(left_opnd, &line, &col);

   NTR_IR_TBL(init_idx);
   IR_OPR(init_idx) = Init_Opr;
   IR_TYPE_IDX(init_idx) = TYPELESS_DEFAULT_TYPE;
   IR_LINE_NUM(init_idx) = line;
   IR_COL_NUM(init_idx)  = col;

   COPY_OPND(IR_OPND_L(init_idx), (*left_opnd));

   COPY_OPND(opnd, (*left_opnd));
   while (OPND_FLD(opnd) == IR_Tbl_Idx) {
      if (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) {
         num_loops++;
      }
      COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
   }

   if (num_loops > 0) {

      if (num_loops == 1) {
         /* set up as a single init with rep count and stride */
         COPY_OPND(opnd, (*left_opnd));
         make_base_subtree(&opnd, &base_opnd, &rank_idx, &unused);

# ifdef _DEBUG
         if (rank_idx == NULL_IDX) {
            PRINTMSG(line, 626, Internal, col,
                     "whole array subscript",
                     "gen_init_stmt");
         }
# endif
         array_attr_idx = find_base_attr(&IR_OPND_L(rank_idx),
                                         &unused,
                                         &unused2);

         bd_idx = ATD_ARRAY_IDX(array_attr_idx);

         COPY_OPND(IR_OPND_L(init_idx), base_opnd);

         NTR_IR_LIST_TBL(list_idx);
         IR_FLD_R(init_idx) = IL_Tbl_Idx;
         IR_IDX_R(init_idx) = list_idx;
         IR_LIST_CNT_R(init_idx) = 3;

         /* value */

         IL_FLD(list_idx) = CN_Tbl_Idx;
         IL_IDX(list_idx) = const_idx;
         IL_LINE_NUM(list_idx) = line;
         IL_COL_NUM(list_idx) = col;

         /* rep count */

         NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
         IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
         list_idx = IL_NEXT_LIST_IDX(list_idx);

# ifdef _DEBUG
         if (BD_LEN_FLD(bd_idx) != CN_Tbl_Idx) {
            PRINTMSG(line, 626, Internal, col,
                     "constant array length",
                     "gen_init_stmt");
         }
# endif
         IL_FLD(list_idx) = CN_Tbl_Idx;
         IL_IDX(list_idx) = BD_LEN_IDX(bd_idx);
         IL_LINE_NUM(list_idx) = line;
         IL_COL_NUM(list_idx) = col;

         /* stride in bits */

         NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
         IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
         list_idx = IL_NEXT_LIST_IDX(list_idx);

# ifdef _SM_UNIT_IS_ELEMENT
         sm_bits = sm_unit_in_bits(ATD_TYPE_IDX(array_attr_idx));
         C_TO_F_INT(the_constant, sm_bits, Integer_8);
# else
         if (TYP_TYPE(ATD_TYPE_IDX(array_attr_idx)) == Structure &&
             ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(array_attr_idx)))) {
            C_TO_F_INT(the_constant, 8, CG_INTEGER_DEFAULT_TYPE);
         }
         else {
            sm_bits = sm_unit_in_bits(ATD_TYPE_IDX(array_attr_idx));
            C_TO_F_INT(the_constant, sm_bits, Integer_8);
         }
# endif

         type_idx = (CG_INTEGER_DEFAULT_TYPE >
                     TYP_LINEAR(CN_TYPE_IDX(BD_SM_IDX(bd_idx, 1))) ?
                      CG_INTEGER_DEFAULT_TYPE :
                             CN_TYPE_IDX(BD_SM_IDX(bd_idx, 1)));


         if (folder_driver((char *)&CN_CONST(BD_SM_IDX(bd_idx, 1)),
                           CN_TYPE_IDX(BD_SM_IDX(bd_idx, 1)),
                           (char *) the_constant,
                           CG_INTEGER_DEFAULT_TYPE,
                           result,
                          &type_idx,
                           line,
                           col,
                           2,
                           Mult_Opr)) {

            IL_FLD(list_idx) = CN_Tbl_Idx;
            IL_IDX(list_idx) = ntr_const_tbl(type_idx,
                                             FALSE,
                                             result);
            IL_LINE_NUM(list_idx) = line;
            IL_COL_NUM(list_idx) = col;
         }
      }
      else {
         /* must be all implied do loops */

         copy_subtree(left_opnd, &opnd, 0, 0);
         count = create_imp_do_loops(&opnd);
         COPY_OPND(IR_OPND_L(init_idx), opnd);

         NTR_IR_LIST_TBL(list_idx);
         IR_FLD_R(init_idx) = IL_Tbl_Idx;
         IR_IDX_R(init_idx) = list_idx;
         IR_LIST_CNT_R(init_idx) = 1;

         NTR_IR_TBL(mult_idx);
         IR_OPR(mult_idx) = Mult_Opr;
         IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
         IR_LINE_NUM(mult_idx) = line;
         IR_COL_NUM(mult_idx)  = col;
         IR_FLD_L(mult_idx) = CN_Tbl_Idx;
         IR_IDX_L(mult_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, count);

         IR_LINE_NUM_L(mult_idx) = line;
         IR_COL_NUM_L(mult_idx)  = col;
         IR_FLD_R(mult_idx) = CN_Tbl_Idx;
         IR_IDX_R(mult_idx) = const_idx;
         IR_LINE_NUM_R(mult_idx) = line;
         IR_COL_NUM_R(mult_idx)  = col;

         IL_FLD(list_idx) = IR_Tbl_Idx;
         IL_IDX(list_idx) = mult_idx;
      }
   }
   else {

      NTR_IR_LIST_TBL(list_idx);
      IR_FLD_R(init_idx) = IL_Tbl_Idx;
      IR_IDX_R(init_idx) = list_idx;
      IR_LIST_CNT_R(init_idx) = 3;

      IL_FLD(list_idx) = CN_Tbl_Idx;
      IL_IDX(list_idx) = const_idx;
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;

      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
      list_idx = IL_NEXT_LIST_IDX(list_idx);

      IL_FLD(list_idx) = CN_Tbl_Idx;
      IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;

      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
      list_idx = IL_NEXT_LIST_IDX(list_idx);

      IL_FLD(list_idx) = CN_Tbl_Idx;
      IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;
   }

   gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   if (position == After) {
      SH_IR_IDX(curr_stmt_sh_idx)     = init_idx;
      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
   }
   else {
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = init_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
   }


   TRACE (Func_Exit, "gen_init_stmt", NULL);

   return;

}  /* gen_init_stmt */
#ifdef KEY /* Bug 6845 */

/*
 * attr_idx	Attribute table index of entity which dope vector represents
 * is_array	True if dope vector represents an array
 * return	If entity is an allocatable array whose element type is a
 *		derived type, and component(s) of the derived type are
 *		themselves allocatable, return the number of allocatable
 *		components; otherwise, return 0. If a component is itself
 *		a structure containing allocatable array subcomponents, we
 *		count them as well.
 */
int
do_count_allocatable_cpnt(int attr_idx, int is_array) {
  if (!is_array) { /* Not an array */
    return 0;
    }
  int element_type_idx = ATD_TYPE_IDX(attr_idx);
  if (TYP_TYPE(element_type_idx) != Structure ||
    !ATT_ALLOCATABLE_CPNT(TYP_IDX(element_type_idx))) {
    return 0;
    }
  int count = 0;
  for (int sn_idx = ATT_FIRST_CPNT_IDX(TYP_IDX(element_type_idx));
    sn_idx != NULL_IDX;
    sn_idx = SN_SIBLING_LINK(sn_idx)) {
    int cpnt_attr_idx = SN_ATTR_IDX(sn_idx);
    if (ATD_ALLOCATABLE(cpnt_attr_idx)) {
      count += 1;
    }
    /* Child structure contains components which are allocatable arrays */
    else if (TYP_TYPE(ATD_TYPE_IDX(cpnt_attr_idx)) == Structure) {
      count += do_count_allocatable_cpnt(cpnt_attr_idx, 1);
    }
  }
  return count;
}

/*
 * Used by do_alloc_cpnt_offset to append one operand to list
 *
 * line		source line
 * col		source column
 * list_idx	index of current operand list item
 * fld		which table the index belongs to
 * idx		index of value of operand
 * returns	index of newly created operand list item
 */
static int
do_one_operand(int line, int col, int list_idx, fld_type fld, int idx) {
   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = fld;
   IL_IDX(list_idx) = idx;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;
   return list_idx;
}

/*
 * Append to list of operands of dv_whole_def_opr a boolean indicating
 * whether the dope vector has a list of allocatable component offsets
 *
 * line		source line
 * col		source column
 * list_idx	index of current list item
 * n_allocatable_cpnt	number of allocatable components
 * return	index of newly created list item
 */
static int
do_alloc_cpnt(int line, int col, int list_idx, int n_allocatable_cpnt) {

   /**************\
   |* ALLOC_CPNT *|
   \**************/

   return do_one_operand(line, col, list_idx, CN_Tbl_Idx,
     (n_allocatable_cpnt ? CN_INTEGER_ONE_IDX : CN_INTEGER_ZERO_IDX));
      
}

/*
 * If the dope vector represents an an allocatable array whose element type
 * is a derived type having allocatable components, append to the list of
 * operands of dv_whole_def_opr a series of byte offsets to the allocatable
 * components
 *
 * line		source line
 * col		source column
 * list_idx	index of current list item (stride of highest dimension of
 *		array)
 * attr_idx	Attribute table index of entity which dope vector represents
 * n_allocatable_cpnt	number of allocatable components
 * return	index of last newly created list item (last offset)
 */
static int
do_alloc_cpnt_offset(int line, int col, int list_idx, int attr_idx,
   int n_allocatable_cpnt) {

   if (0 == n_allocatable_cpnt) {
     return list_idx;
   }

   /*********************\
   |* ALLOC CPNT OFFSET *|
   \*********************/

  int element_type_idx = ATD_TYPE_IDX(attr_idx);
  for (int sn_idx = ATT_FIRST_CPNT_IDX(TYP_IDX(element_type_idx));
    sn_idx != NULL_IDX;
    sn_idx = SN_SIBLING_LINK(sn_idx)) {
    int cpnt_attr_idx = SN_ATTR_IDX(sn_idx);
    if (ATD_ALLOCATABLE(cpnt_attr_idx)) {
      list_idx = do_one_operand(line, col, list_idx,
	ATD_OFFSET_FLD(cpnt_attr_idx), ATD_CPNT_OFFSET_IDX(cpnt_attr_idx));
    }
    /* Child structure contains components which are allocatable arrays */
    else if (TYP_TYPE(ATD_TYPE_IDX(cpnt_attr_idx)) == Structure) {
      list_idx = do_alloc_cpnt_offset(line, col, list_idx, cpnt_attr_idx,
        n_allocatable_cpnt);
    }
  }
  return list_idx;
}
#endif /* KEY Bug 6845 */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Gen the dv_whole_def_opr to set a dope vector in one operation.       *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void gen_dv_whole_def(opnd_type		*dv_opnd,
		      opnd_type		*r_opnd,
		      expr_arg_type     *exp_desc)

{
   act_arg_type a_type;
   int		asg_idx;
#ifdef KEY /* Bug 10177 */
   int		attr_idx = 0;
#else /* KEY Bug 10177 */
   int		attr_idx;
#endif /* KEY Bug 10177 */
   opnd_type	base_opnd;
   int		col;
   int		dim = 1;
   int		dope_idx = NULL_IDX;
   int		dv_attr_idx;
   int		dv2_idx;
   int		i;
   int		ir_idx;
   opnd_type	len_opnd;
   int		line;
   int		list_idx;
   int		list2_idx;
   int		loc_idx;
   int		max_idx;
   int		mult_idx;
   opnd_type    opnd;
   long		rank;
   int		rank_idx = NULL_IDX;
   opnd_type    r_dv_opnd;
   int          stride_idx;
   opnd_type	stride_opnd;
#ifdef KEY /* Bug 10177 */
   int          subscript_idx = 0;
#else /* KEY Bug 10177 */
   int          subscript_idx;
#endif /* KEY Bug 10177 */
   int          type_idx;
   boolean      whole_array;


   TRACE (Func_Entry, "gen_dv_whole_def", NULL);

   dv_attr_idx = find_base_attr(dv_opnd, &line, &col);

   NTR_IR_TBL(asg_idx);
   IR_OPR(asg_idx) = Dv_Def_Asg_Opr;
   IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(asg_idx) = line;
   IR_COL_NUM(asg_idx)  = col;

   NTR_IR_TBL(ir_idx);
   IR_OPR(ir_idx) = Dv_Whole_Def_Opr;
   IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(ir_idx) = line;
   IR_COL_NUM(ir_idx)  = col;

   COPY_OPND(IR_OPND_L(asg_idx), (*dv_opnd));
   IR_FLD_R(asg_idx) = IR_Tbl_Idx;
   IR_IDX_R(asg_idx) = ir_idx;

   NTR_IR_LIST_TBL(list_idx);
   IR_FLD_L(ir_idx) = IL_Tbl_Idx;
   IR_IDX_L(ir_idx) = list_idx;

   rank = (ATD_ARRAY_IDX(dv_attr_idx) ? 
                         (long) BD_RANK(ATD_ARRAY_IDX(dv_attr_idx)) : 0);
#ifdef KEY /* Bug 6845 */
   int n_allocatable_cpnt = IR_DV_N_ALLOC_CPNT(ir_idx) =
     do_count_allocatable_cpnt(dv_attr_idx, rank);
   IR_LIST_CNT_L(ir_idx) = 11 + (3 * rank) + n_allocatable_cpnt;
#else /* KEY Bug 6845 */
   IR_LIST_CNT_L(ir_idx) = 10 + (3 * rank);
#endif /* KEY Bug 6845 */
   IR_DV_DIM(ir_idx) = rank;

   /*************\
   |* BASE ADDR *|
   \*************/

   NTR_IR_TBL(loc_idx);
   IR_OPR(loc_idx)  = Loc_Opr;
   IR_LINE_NUM(loc_idx) = line;
   IR_COL_NUM(loc_idx)  = col;

   if (exp_desc->type == Character) {
      IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
   }
   else {
      IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
   }

   IL_FLD(list_idx) = IR_Tbl_Idx;
   IL_IDX(list_idx) = loc_idx;

   if (exp_desc->rank == 0) {
      COPY_OPND(IR_OPND_L(loc_idx), (*r_opnd));
      just_find_dope_and_rank(r_opnd, &rank_idx, &dope_idx);
   }
   else {
      make_base_subtree(r_opnd, &base_opnd, &rank_idx, &dope_idx);
      COPY_OPND(IR_OPND_L(loc_idx), base_opnd);
   }

# ifdef _TRANSFORM_CHAR_SEQUENCE
# ifdef _TARGET_OS_UNICOS
   if (exp_desc->type == Structure &&
       ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) {

      IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
      COPY_OPND(opnd, IR_OPND_L(loc_idx));
      transform_char_sequence_ref(&opnd, exp_desc->type_idx);
      COPY_OPND(IR_OPND_L(loc_idx), opnd);
   }
# endif
# endif


   /*************************\
   |* check for whole array *|
   \*************************/

   if (rank_idx != NULL_IDX) {
      attr_idx      = find_base_attr(&IR_OPND_L(rank_idx), &line, &col);
  
      if (ATD_IM_A_DOPE(attr_idx)) {
         COPY_OPND(r_dv_opnd, IR_OPND_L(IR_IDX_L(rank_idx)));
      }
      subscript_idx = IR_IDX_R(rank_idx);
   }
   else if (exp_desc->rank != 0)              {
      attr_idx    = find_base_attr(r_opnd, &line, &col);
 
      if (ATD_IM_A_DOPE(attr_idx)) {
         COPY_OPND(r_dv_opnd, IR_OPND_L(OPND_IDX((*r_opnd))));
      }
   }
   else {
      find_opnd_line_and_column(r_opnd, &line, &col);
   }

   if (exp_desc->rank > 0 &&
       ! exp_desc->section) {

      whole_array = TRUE;
   }
   else {
      whole_array = FALSE;
   }

   /*************\
   |* EL_LEN    *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);
   type_idx = ATD_TYPE_IDX(dv_attr_idx);

   if (TYP_TYPE(type_idx) == Structure) {
      IL_FLD(list_idx)		= ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
      IL_IDX(list_idx)		= ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
      IL_LINE_NUM(list_idx)	= line;
      IL_COL_NUM(list_idx)	= col;
   }
   else if (TYP_TYPE(type_idx) == Character) {

      COPY_OPND(opnd, exp_desc->char_len);
      OPND_LINE_NUM(opnd) = line;
      OPND_COL_NUM(opnd) = col;
      compute_char_element_len(&opnd, r_opnd, &len_opnd);

      COPY_OPND(IL_OPND(list_idx), len_opnd);
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx) = col;
   }
   else {
      IL_FLD(list_idx) = CN_Tbl_Idx;
      IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
                                    storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;
   }

   /*************\
   |* ASSOC     *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   /*************\
   |* PTR_ALLOC *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   if (dope_idx != NULL_IDX) {

      NTR_IR_TBL(dv2_idx);
      IR_OPR(dv2_idx) = Dv_Access_Ptr_Alloc;
      IR_TYPE_IDX(dv2_idx) = CG_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv2_idx) = line;
      IR_COL_NUM(dv2_idx)  = col;
      COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
      IL_FLD(list_idx) = IR_Tbl_Idx;
      IL_IDX(list_idx) = dv2_idx;
   }
   else {
      IL_FLD(list_idx) = CN_Tbl_Idx;
      IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;
   }


   /*************\
   |* P_OR_A    *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;

   if (ATD_ALLOCATABLE(dv_attr_idx)) {
      IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 2);
   }
   else if (ATD_POINTER(dv_attr_idx)) {
      IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
   }
   else {
      IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
   }
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;



   /*************\
   |* A_CONTIG  *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   a_type = get_act_arg_type(exp_desc);

   if (a_type == Array_Ptr ||
       a_type == Array_Tmp_Ptr ||
       a_type == Whole_Ass_Shape ||
       a_type == Dv_Contig_Section) {

      NTR_IR_TBL(dv2_idx);
      IR_OPR(dv2_idx) = Dv_Access_A_Contig;
      IR_TYPE_IDX(dv2_idx)   = CG_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv2_idx) = line;
      IR_COL_NUM(dv2_idx)  = col;
      COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
      IL_FLD(list_idx) = IR_Tbl_Idx;
      IL_IDX(list_idx) = dv2_idx;

   }
   else if (a_type == Whole_Allocatable ||
            a_type == Whole_Tmp_Allocatable ||
            a_type == Whole_Sequence ||
            a_type == Whole_Tmp_Sequence ||
            a_type == Whole_Array_Constant ||
            a_type == Contig_Section) {

      IL_FLD(list_idx) = CN_Tbl_Idx;
      IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;
   }
   else {
      IL_FLD(list_idx) = CN_Tbl_Idx;
      IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;
   }


   /*************\
   |* N_DIM     *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, rank);
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;


   /*************\
   |* TYPE_CODE *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = create_dv_type_code(dv_attr_idx);
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   /*************\
   |* ORIG_BASE *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   if (dope_idx != NULL_IDX) {

      NTR_IR_TBL(dv2_idx);
      IR_OPR(dv2_idx) = Dv_Access_Orig_Base;
      IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv2_idx) = line;
      IR_COL_NUM(dv2_idx)  = col;
      COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
      IL_FLD(list_idx) = IR_Tbl_Idx;
      IL_IDX(list_idx) = dv2_idx;
   }
   else {
      IL_FLD(list_idx) = CN_Tbl_Idx;
      IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;
   }


   /*************\
   |* ORIG_SIZE *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   if (dope_idx != NULL_IDX) {

      NTR_IR_TBL(dv2_idx);
      IR_OPR(dv2_idx) = Dv_Access_Orig_Size;
      IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv2_idx) = line;
      IR_COL_NUM(dv2_idx)  = col;
      COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
      IL_FLD(list_idx) = IR_Tbl_Idx;
      IL_IDX(list_idx) = dv2_idx;
   }
   else {
      IL_FLD(list_idx) = CN_Tbl_Idx;
      IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;
   }

#ifdef KEY /* Bug 6845 */
   list_idx = do_alloc_cpnt(line, col, list_idx, n_allocatable_cpnt);
#endif /* KEY Bug 6845 */

   for (i = 1; i <= rank; i++) {

      /*************\
      |* DIM i LB  *|
      \*************/

      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
      list_idx = IL_NEXT_LIST_IDX(list_idx);

      if (whole_array) {
         /* need arrays low bound */
         if (ATD_IM_A_DOPE(attr_idx) &&
             BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) != Assumed_Shape) {
            NTR_IR_TBL(dv2_idx);
            IR_OPR(dv2_idx)    = Dv_Access_Low_Bound;
            IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE;
            IR_LINE_NUM(dv2_idx) = line;
            IR_COL_NUM(dv2_idx)  = col;
            COPY_OPND(IR_OPND_L(dv2_idx), r_dv_opnd);
            IR_DV_DIM(dv2_idx) = i;
            IL_FLD(list_idx)   = IR_Tbl_Idx;
            IL_IDX(list_idx)   = dv2_idx;
         }
         else {
            IL_FLD(list_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx), i);
            IL_IDX(list_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx), i);
            IL_LINE_NUM(list_idx) = line;
            IL_COL_NUM(list_idx)  = col;

            if (IL_FLD(list_idx) == AT_Tbl_Idx) {
               ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx));
            }
         }
      }
      else {
         /* set to one */
         IL_FLD(list_idx) = CN_Tbl_Idx;
         IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
         IL_LINE_NUM(list_idx) = line;
         IL_COL_NUM(list_idx)  = col;
      }


      /*************\
      |* DIM i EX  *|
      \*************/

      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
      list_idx = IL_NEXT_LIST_IDX(list_idx);

      NTR_IR_TBL(max_idx);
      IR_OPR(max_idx) = Max_Opr;
      IR_TYPE_IDX(max_idx) = CG_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(max_idx) = line;
      IR_COL_NUM(max_idx)  = col;

      NTR_IR_LIST_TBL(list2_idx);
      IR_FLD_L(max_idx) = IL_Tbl_Idx;
      IR_LIST_CNT_L(max_idx) = 2;
      IR_IDX_L(max_idx) = list2_idx;

      IL_FLD(list2_idx) = CN_Tbl_Idx;
      IL_IDX(list2_idx) = CN_INTEGER_ZERO_IDX;
      IL_LINE_NUM(list2_idx) = line;
      IL_COL_NUM(list2_idx)  = col;

      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx;
      list2_idx = IL_NEXT_LIST_IDX(list2_idx);

      COPY_OPND(IL_OPND(list2_idx), exp_desc->shape[i-1]);
      IL_LINE_NUM(list2_idx) = line;
      IL_COL_NUM(list2_idx) = col;

      IL_FLD(list_idx) = IR_Tbl_Idx;
      IL_IDX(list_idx) = max_idx;

      /*************\
      |* DIM i SM  *|
      \*************/

      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
      list_idx = IL_NEXT_LIST_IDX(list_idx);

      if (whole_array) {

         gen_dv_stride_mult(&stride_opnd,
                             attr_idx,
                            &r_dv_opnd,
                             exp_desc,
                             i,
                             line,
                             col);
                            
         COPY_OPND(IL_OPND(list_idx), stride_opnd);

      }
      else {
         while (IL_FLD(subscript_idx) != IR_Tbl_Idx ||
                IR_OPR(IL_IDX(subscript_idx)) != Triplet_Opr) {
            subscript_idx = IL_NEXT_LIST_IDX(subscript_idx);
            dim++;
         }

         gen_dv_stride_mult(&stride_opnd,
                             attr_idx,
                            &r_dv_opnd,
                             exp_desc,
                             dim,
                             line,
                             col);

         stride_idx = IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_L(
                                                      IL_IDX(subscript_idx))));

         mult_idx = gen_ir(OPND_FLD(stride_opnd), OPND_IDX(stride_opnd),
                       Mult_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                           IL_FLD(stride_idx), IL_IDX(stride_idx));

         IL_FLD(list_idx) = IR_Tbl_Idx;
         IL_IDX(list_idx) = mult_idx;

         subscript_idx = IL_NEXT_LIST_IDX(subscript_idx);
         dim++;
      }
   }

#ifdef KEY /* Bug 6845 */
   list_idx = do_alloc_cpnt_offset(line, col, list_idx, dv_attr_idx,
     n_allocatable_cpnt);
#endif /* KEY Bug 6845 */

   gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   TRACE (Func_Exit, "gen_dv_whole_def", NULL);

   return;

}  /* gen_dv_whole_def */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

static void gen_dv_stride_mult(opnd_type	*stride_opnd,
                               int		 attr_idx,
                               opnd_type	*r_dv_opnd,
                               expr_arg_type	*exp_desc,
                               int		 dim,
                               int		 line,
                               int		 col)

{
# if defined(_EXTENDED_CRI_CHAR_POINTER)
   int		clen_idx;
# endif

   int		cn_idx;
   int		dv_idx;
   int		ir_idx;
   long64	res_sm_unit_in_bits, orig_res_sm_unit_in_bits;
   long64	src_sm_unit_in_bits;


   TRACE (Func_Entry, "gen_dv_stride_mult", NULL);

   /* res_sm_unit_in_bits describes the sm unit for the result dv */

   if (exp_desc->type == Structure &&
       ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) {
      res_sm_unit_in_bits = sm_unit_in_bits(Character_1);
   }
   else {
      res_sm_unit_in_bits = sm_unit_in_bits(exp_desc->type_idx);
      orig_res_sm_unit_in_bits = res_sm_unit_in_bits;
# ifdef _WHIRL_HOST64_TARGET64
      if (res_sm_unit_in_bits > 32)
        res_sm_unit_in_bits = 32;
# endif /* _WHIRL_HOST64_TARGET64 */
   }

   /* src_sm_unit_in_bits describes the sm unit for the arrays bd entry */

   if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure &&
       ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {
      src_sm_unit_in_bits = sm_unit_in_bits(Character_1);
   }
   else {
      src_sm_unit_in_bits = sm_unit_in_bits(ATD_TYPE_IDX(attr_idx));
   }

# ifdef _DEBUG
   if (res_sm_unit_in_bits == 0 || src_sm_unit_in_bits == 0) {
      PRINTMSG(line, 626, Internal, col,
               "stride_mult_unit_in_bits",
               "gen_dv_stride_mult");
   }
# endif


   if (ATD_IM_A_DOPE(attr_idx)) {
      NTR_IR_TBL(dv_idx);
      IR_OPR(dv_idx) = Dv_Access_Stride_Mult;
      IR_TYPE_IDX(dv_idx) = SA_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(dv_idx) = line;
      IR_COL_NUM(dv_idx)  = col;
      COPY_OPND(IR_OPND_L(dv_idx), (*r_dv_opnd));
      IR_DV_DIM(dv_idx) = dim;

      OPND_FLD((*stride_opnd)) = IR_Tbl_Idx;
      OPND_IDX((*stride_opnd)) = dv_idx;
      /* Dope vectors already have the correct stride multiplier */
      res_sm_unit_in_bits = orig_res_sm_unit_in_bits;

   }
   else {
      OPND_FLD((*stride_opnd)) = BD_SM_FLD(ATD_ARRAY_IDX(attr_idx), dim);
      OPND_IDX((*stride_opnd)) = BD_SM_IDX(ATD_ARRAY_IDX(attr_idx), dim);
      OPND_LINE_NUM((*stride_opnd)) = line;
      OPND_COL_NUM((*stride_opnd))  = col;

      if (OPND_FLD((*stride_opnd)) == AT_Tbl_Idx) {
         ADD_TMP_TO_SHARED_LIST(OPND_IDX((*stride_opnd)));
      }

# if defined(_EXTENDED_CRI_CHAR_POINTER) 
      if (ATD_CLASS(attr_idx) == CRI__Pointee &&
# if defined(KEY)
          AT_IS_DARG(attr_idx) &&
# endif
          TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {

         NTR_IR_TBL(ir_idx);
         IR_OPR(ir_idx)        = Mult_Opr;
         IR_TYPE_IDX(ir_idx)   = CG_INTEGER_DEFAULT_TYPE;
         IR_LINE_NUM(ir_idx)   = line;
         IR_COL_NUM(ir_idx)    = col;

         COPY_OPND(IR_OPND_L(ir_idx), (*stride_opnd));

         NTR_IR_TBL(clen_idx);
         IR_OPR(clen_idx) = Clen_Opr;
         IR_TYPE_IDX(clen_idx) = CG_INTEGER_DEFAULT_TYPE;
         IR_LINE_NUM(clen_idx)   = line;
         IR_COL_NUM(clen_idx)    = col;
         IR_FLD_L(clen_idx) = AT_Tbl_Idx;
         IR_IDX_L(clen_idx) = attr_idx;
         IR_LINE_NUM_L(clen_idx)   = line;
         IR_COL_NUM_L(clen_idx)    = col;

         IR_FLD_R(ir_idx) = IR_Tbl_Idx;
         IR_IDX_R(ir_idx) = clen_idx;

         OPND_FLD((*stride_opnd))   = IR_Tbl_Idx;
         OPND_IDX((*stride_opnd))   = ir_idx;
      }
# endif
   }

# ifndef _SM_UNIT_IS_ELEMENT
   if (src_sm_unit_in_bits != res_sm_unit_in_bits) {

      /* BRIANJ - C_INT_TO_CN has the capability of switching this to */
      /* Integer_8 automatically.  See me  KAY */


      cn_idx =  C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
                            (src_sm_unit_in_bits / res_sm_unit_in_bits));

      ir_idx = gen_ir(OPND_FLD((*stride_opnd)), 
                      OPND_IDX((*stride_opnd)),
                      Mult_Opr, 
                      CG_INTEGER_DEFAULT_TYPE, 
                      line,
                      col,
                      CN_Tbl_Idx,
                      cn_idx);

      OPND_FLD((*stride_opnd))   = IR_Tbl_Idx;
      OPND_IDX((*stride_opnd))   = ir_idx;
   }
# endif


   TRACE (Func_Exit, "gen_dv_stride_mult", NULL);

   return;

}  /* gen_dv_stride_mult */

#ifdef KEY /* Bug 6845 */
/*
 * Insert Dv_Deref_Opr between Subscript_Opr and array
 *
 * line		Source line
 * col		Source column
 * parent_idx	IR_Tbl_Idx index of parent (Subscript_Opr) node
 * child_idx	AT_Tbl_Idx index of child (array) node
 */
static void
insert_dv_deref(int line, int col, int parent_idx, int child_idx) {
  int dv_deref_idx;
  NTR_IR_TBL(dv_deref_idx);
  IR_OPR(dv_deref_idx) = Dv_Deref_Opr;
  IR_TYPE_IDX(dv_deref_idx) = ATD_TYPE_IDX(child_idx);
  IR_LINE_NUM_L(dv_deref_idx) = IR_LINE_NUM(dv_deref_idx) = line;
  IR_COL_NUM_L(dv_deref_idx) = IR_COL_NUM(dv_deref_idx)  = col;
  IR_FLD_L(dv_deref_idx) = AT_Tbl_Idx;
  IR_IDX_L(dv_deref_idx) = child_idx;
  IR_FLD_R(dv_deref_idx) = NO_Tbl_Idx;
  IR_IDX_R(dv_deref_idx) = NULL_IDX;
  IR_FLD_L(parent_idx) = IR_Tbl_Idx;
  IR_IDX_L(parent_idx) = dv_deref_idx;
}

/*
 * Call this before gen_loops()
 *
 * line		Source line
 * col		Source column
 * return	idx of placeholder for use in post_gen_loops()
 * next_sh_idx	idx of statement that will follow the end of the last loop
 *		once we finish generating loops
 */
int
pre_gen_loops(int line, int col, int *next_sh_idx) {
  gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
  *next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
  return curr_stmt_sh_idx;
}

/*
 * After calling gen_loops() and creating the body of the loops, call this.
 *
 * placeholder_sh_idx	idx from pre_gen_loops()
 * next_sh_idx		idx of the statement that follows the end of the last
 *			loop
 */
void
post_gen_loops(int placeholder_sh_idx, int next_sh_idx) {
  remove_sh(placeholder_sh_idx);
  FREE_SH_NODE(placeholder_sh_idx);
  if (next_sh_idx != NULL_IDX) {
    curr_stmt_sh_idx = SH_PREV_IDX(next_sh_idx);
  }
  else {
    while (SH_NEXT_IDX(curr_stmt_sh_idx) != NULL_IDX) {
      curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
    }
  }
}

/*
 * Generate loops to traverse all elements of an array represented by
 * Whole_Subscript_Opr or Section_Subscript_Opr opnd_l. Transform opnd_l to
 * use the loop index variables as its subscripts. If optional argument
 * opnd_r is present, transform it likewise.
 *
 * The illogic of the statement structure (inherited from gen_dv_def_loops,
 * which we generalized to make gen_loops) is that the loops will surround
 * the statement associated with curr_stmt_sh_idx, leaving curr_stmt_sh_idx
 * set to that statement rather than to the end of the last loop. The usual
 * technique is to create a placeholder, save its index, create the loops,
 * add statements after the placeholder, delete the placeholder, move
 * curr_stmt_sh_idx to the end of the last loop. Yuck. See pre_gen_loops()
 * and post_gen_loops().
 *
 * opnd_l	Whole_Subscript_Opr or Section_Subscript_Opr for destination
 *		array
 * opnd_r	Whole_Subscript_Opr or Section_Subscript_Opr for source
 *		array which must be conformable with opnd_l (or else null)
 * deref	If true, generate dv_deref_idx between the Subscript_Opr and
 *		the array variable if that variable is a dope vector
 */
void
gen_loops(opnd_type *opnd_l, opnd_type *opnd_r, boolean deref)
{
   int		col;
   int		line;
   opnd_type	temp_l;

   TRACE (Func_Entry, "gen_loops", NULL);

   find_opnd_line_and_column(opnd_l, &line, &col);

   opnd_type next;
   int subscripts[STATIC_SUBSCRIPT_SIZE];
   int subscript_cnt = 0;
   for (COPY_OPND(temp_l, *opnd_l);
      (OPND_FLD(temp_l) == IR_Tbl_Idx);
      COPY_OPND(temp_l, next)) {

      operator_type ir_opr = IR_OPR(OPND_IDX(temp_l));
      if (ir_opr == Whole_Subscript_Opr || ir_opr == Section_Subscript_Opr) {

         IR_OPR(OPND_IDX(temp_l)) = Subscript_Opr;

         for (int list_idx = IR_IDX_R(OPND_IDX(temp_l));
	    list_idx != NULL_IDX;
	    list_idx = IL_NEXT_LIST_IDX(list_idx)) {

            if (IL_FLD(list_idx) == IR_Tbl_Idx &&
                IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) {

               int tmp_idx = subscripts[subscript_cnt++] =
	         gen_compiler_tmp(line, col, Priv, TRUE);
            
               ATD_TYPE_IDX(tmp_idx) = CG_INTEGER_DEFAULT_TYPE;
               ATD_STOR_BLK_IDX(tmp_idx)  = SCP_SB_STACK_IDX(curr_scp_idx);
               AT_SEMANTICS_DONE(tmp_idx) = TRUE;

               int list_idx2 = IR_IDX_L(IL_IDX(list_idx));
	       opnd_type start_opnd;
	       opnd_type stride_opnd;
	       opnd_type end_opnd;

               COPY_OPND(start_opnd, IL_OPND(list_idx2));

               list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
               COPY_OPND(end_opnd, IL_OPND(list_idx2));

               list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
               COPY_OPND(stride_opnd, IL_OPND(list_idx2));

               create_loop_stmts(tmp_idx, &start_opnd, &end_opnd, &stride_opnd,
                                 curr_stmt_sh_idx,     /* body start sh idx */
                                 curr_stmt_sh_idx);    /* body end sh idx */

               IL_FLD(list_idx) = AT_Tbl_Idx;
               IL_IDX(list_idx) = tmp_idx;
               IL_LINE_NUM(list_idx) = line;
               IL_COL_NUM(list_idx) = col;
            }
         }
      }

      next = IR_OPND_L(OPND_IDX(temp_l));
      if (deref && ir_opr != Dv_Deref_Opr && OPND_FLD(next) == AT_Tbl_Idx &&
        ATD_IM_A_DOPE(OPND_IDX(next))) {
	insert_dv_deref(line, col, OPND_IDX(temp_l), OPND_IDX(next));
      }
   }

   if (opnd_r) {
      subscript_cnt = 0;
      opnd_type temp_r;
      for (COPY_OPND(temp_r, (*opnd_r));
	OPND_FLD(temp_r) == IR_Tbl_Idx;
	COPY_OPND(temp_r, next)) {

	operator_type ir_opr = IR_OPR(OPND_IDX(temp_r));
	if (ir_opr == Whole_Subscript_Opr || ir_opr == Section_Subscript_Opr) {

	   IR_OPR(OPND_IDX(temp_r)) = Subscript_Opr;

	   for (int list_idx = IR_IDX_R(OPND_IDX(temp_r));
	      list_idx != NULL_IDX;
	      list_idx = IL_NEXT_LIST_IDX(list_idx)) {

	      if (IL_FLD(list_idx) == IR_Tbl_Idx &&
		 IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) {

		 IL_FLD(list_idx) = AT_Tbl_Idx;
		 IL_IDX(list_idx) = subscripts[subscript_cnt++];
		 IL_LINE_NUM(list_idx) = line;
		 IL_COL_NUM(list_idx) = col;
	      }
	   }
	}

	next = IR_OPND_L(OPND_IDX(temp_r));
	if (deref && ir_opr != Dv_Deref_Opr && OPND_FLD(next) == AT_Tbl_Idx &&
	  ATD_IM_A_DOPE(OPND_IDX(next))) {
	  insert_dv_deref(line, col, OPND_IDX(temp_r), OPND_IDX(next));
	}
     }
   }

   TRACE (Func_Exit, "gen_loops", NULL);
}  /* gen_loops */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

static void
gen_dv_def_loops(opnd_type	*dv_opnd)

{
   gen_loops(dv_opnd, 0, FALSE);
}
#endif /* KEY Bug 6845 */
/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Gen the dv_whole_def_opr to set a dope vector in one operation.       *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void gen_dv_whole_def_init(opnd_type		*dv_opnd,
			   int		 	dv_attr_idx,
			   sh_position_type	position)

{
   int			asg_idx;
   int			col;
   int			i;
   int			ir_idx;
   size_offset_type	length;
   int			line;
   int			list_idx;
   int			mult_idx;
   long			rank;
   size_offset_type	result;
   int			type_idx;


   TRACE (Func_Entry, "gen_dv_whole_def_init", NULL);

   find_opnd_line_and_column(dv_opnd, &line, &col);

   NTR_IR_TBL(asg_idx);
   IR_OPR(asg_idx) = Dv_Def_Asg_Opr;
   IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(asg_idx) = line;
   IR_COL_NUM(asg_idx)  = col;

   NTR_IR_TBL(ir_idx);
   IR_OPR(ir_idx) = Dv_Whole_Def_Opr;
   IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(ir_idx) = line;
   IR_COL_NUM(ir_idx)  = col;

   COPY_OPND(IR_OPND_L(asg_idx), (*dv_opnd));
   IR_FLD_R(asg_idx) = IR_Tbl_Idx;
   IR_IDX_R(asg_idx) = ir_idx;

   NTR_IR_LIST_TBL(list_idx);
   IR_FLD_L(ir_idx) = IL_Tbl_Idx;
   IR_IDX_L(ir_idx) = list_idx;

   rank = ATD_ARRAY_IDX(dv_attr_idx) ?
                        (long) BD_RANK(ATD_ARRAY_IDX(dv_attr_idx)) : 0;
#ifdef KEY /* Bug 6845 */
   int n_allocatable_cpnt = IR_DV_N_ALLOC_CPNT(ir_idx) =
     do_count_allocatable_cpnt(dv_attr_idx, rank);
   IR_LIST_CNT_L(ir_idx) = 11 + (3 * rank) + n_allocatable_cpnt;
#else /* KEY Bug 6845 */
   IR_LIST_CNT_L(ir_idx) = 10 + (3 * rank);
#endif /* KEY Bug 6845 */
   IR_DV_DIM(ir_idx) = rank;

   /*************\
   |* BASE ADDR *|
   \*************/

#ifdef KEY /* Bug 6106 */
   /* We want to set the base address to null explicitly so the code behaves
    * reproducibly if the user fails to allocate or initialize the variable.
    */
   IL_FLD(list_idx) = IR_Tbl_Idx;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)	= col;

   int fcd_idx;
   NTR_IR_TBL(fcd_idx);
   IL_IDX(list_idx) = fcd_idx;
   IR_OPR(fcd_idx) = Aloc_Opr;
   IR_TYPE_IDX(fcd_idx) = CRI_Ptr_8;
   IR_LINE_NUM(fcd_idx) = line;
   IR_COL_NUM(fcd_idx)  = col;

   IR_FLD_L(fcd_idx) = CN_Tbl_Idx;
   IR_IDX_L(fcd_idx) = (SA_INTEGER_DEFAULT_TYPE == CG_INTEGER_DEFAULT_TYPE) ?
     CN_INTEGER_ZERO_IDX : 
     C_INT_TO_CN(SA_INTEGER_DEFAULT_TYPE, 0);
   IR_LINE_NUM_L(fcd_idx) = line;
   IR_COL_NUM_L(fcd_idx)  = col;
#else /* KEY Bug 6106 */
   /* leave as null ops */
#endif /* KEY Bug 6106 */

   /*************\
   |* EL_LEN    *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);
   type_idx = ATD_TYPE_IDX(dv_attr_idx);

   if (TYP_TYPE(type_idx) == Structure) {
      IL_FLD(list_idx)	= (fld_type) ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
      IL_IDX(list_idx)	= ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
      IL_LINE_NUM(list_idx)	= line;
      IL_COL_NUM(list_idx)	= col;
   }
   else if (TYP_TYPE(type_idx) == Character) {

      IL_FLD(list_idx)      = TYP_FLD(type_idx);
      IL_IDX(list_idx)      = TYP_IDX(type_idx);
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;

      if (IL_FLD(list_idx) == AT_Tbl_Idx) {
         ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx));
      }

      if (! char_len_in_bytes) {
         /* Len is in bytes on solaris */
         /* Len is in bits for everyone else */

         if (TYP_FLD(type_idx) == CN_Tbl_Idx) {
            result.fld		= CN_Tbl_Idx;
            result.idx		= CN_INTEGER_CHAR_BIT_IDX;
            length.fld		= TYP_FLD(type_idx);
            length.idx		= TYP_IDX(type_idx);
   
            size_offset_binary_calc(&length,
                                    &result,
                                     Mult_Opr,
                                    &result);

            if (result.fld == NO_Tbl_Idx) {
               IL_FLD(list_idx)       = CN_Tbl_Idx;
               IL_IDX(list_idx)       = ntr_const_tbl(result.type_idx,
                                                      FALSE,
                                                      result.constant);
            }
            else {
               IL_FLD(list_idx)       = result.fld;
               IL_IDX(list_idx)       = result.idx;
            }

            IL_LINE_NUM(list_idx) = line;
            IL_COL_NUM(list_idx)  = col;
         }
         else {
            NTR_IR_TBL(mult_idx);
            IR_OPR(mult_idx) = Mult_Opr;
            IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
            IR_LINE_NUM(mult_idx) = line;
            IR_COL_NUM(mult_idx)  = col;
            IR_FLD_L(mult_idx)    = CN_Tbl_Idx;
            IR_IDX_L(mult_idx)    = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8);
            IR_LINE_NUM_L(mult_idx) = line;
            IR_COL_NUM_L(mult_idx)  = col;
   
            IR_FLD_R(mult_idx)    = TYP_FLD(type_idx);
            IR_IDX_R(mult_idx)    = TYP_IDX(type_idx);
            IR_LINE_NUM_R(mult_idx) = line;
            IR_COL_NUM_R(mult_idx)  = col;

            IL_FLD(list_idx)      = IR_Tbl_Idx;
            IL_IDX(list_idx)      = mult_idx;
         }
      }
   }
   else {
      IL_FLD(list_idx) = CN_Tbl_Idx;
      IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 
                                    storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;
   }

   /*************\
   |* ASSOC     *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   /*************\
   |* PTR_ALLOC *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;


   /*************\
   |* P_OR_A    *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;

   if (ATD_ALLOCATABLE(dv_attr_idx)) {
      IL_IDX(list_idx) = CN_INTEGER_TWO_IDX;
   }
   else if (ATD_POINTER(dv_attr_idx)) {
      IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
   }
   else {
      IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
   }
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;



   /*************\
   |* A_CONTIG  *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;

   if (ATD_ALLOCATABLE(dv_attr_idx)) {
      IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
   }
   else {
#ifdef KEY /* Bug 9608 */
      /*
       * When we set assoc=0 for an array, we also set contig=1 so that
       * copyinout doesn't blow up if user (illegally) passes the null pointer
       * to a procedure lacking an explicit interface, in the (unjustified)
       * expectation that the pointer won't be dereferenced if the procedure
       * doesn't refer to the dummy argument. This seems cheaper than adding
       * a test for null before and after every call.
       */
      IL_IDX(list_idx) = rank ? CN_INTEGER_ONE_IDX : CN_INTEGER_ZERO_IDX;
#else /* KEY Bug 9608 */
      IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
#endif /* KEY Bug 9608 */
   }
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;


   /*************\
   |* N_DIM     *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, rank);
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;


   /*************\
   |* TYPE_CODE *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = create_dv_type_code(dv_attr_idx);
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   /*************\
   |* ORIG_BASE *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   /*************\
   |* ORIG_SIZE *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

#ifdef KEY /* Bug 6845 */
   list_idx = do_alloc_cpnt(line, col, list_idx, n_allocatable_cpnt);
#endif /* KEY Bug 6845 */

   for (i = 1; i <= rank; i++) {

      /*************\
      |* DIM i LB  *|
      \*************/

      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
      list_idx = IL_NEXT_LIST_IDX(list_idx);

      if (cmd_line_flags.runtime_bounds) {
         IL_FLD(list_idx) = CN_Tbl_Idx;
         IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
         IL_LINE_NUM(list_idx) = line;
         IL_COL_NUM(list_idx) = col;
      }

      /*************\
      |* DIM i EX  *|
      \*************/

      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
      list_idx = IL_NEXT_LIST_IDX(list_idx);

      if (cmd_line_flags.runtime_bounds) {
         IL_FLD(list_idx) = CN_Tbl_Idx;
         IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
         IL_LINE_NUM(list_idx) = line;
         IL_COL_NUM(list_idx) = col;
      }

      /*************\
      |* DIM i SM  *|
      \*************/

      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
      list_idx = IL_NEXT_LIST_IDX(list_idx);

      if (cmd_line_flags.runtime_bounds) {
         IL_FLD(list_idx) = CN_Tbl_Idx;
         IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
         IL_LINE_NUM(list_idx) = line;
         IL_COL_NUM(list_idx) = col;
      }
   }

#ifdef KEY /* Bug 6845 */
   list_idx = do_alloc_cpnt_offset(line, col, list_idx, dv_attr_idx,
     n_allocatable_cpnt);
#endif /* KEY Bug 6845 */

   gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   if (position == After) {
      SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
   }
   else {
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
   }

   TRACE (Func_Exit, "gen_dv_whole_def_init", NULL);

   return;

} /* gen_dv_whole_def_init */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Make a copy of a reference subtree where sections are replace by      *|
|*      the start value (or lower bound). This is to get the base address     *|
|*      of an array section.                                                  *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      old_opnd - root of original tree.                                     *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      new_opnd - root of copy.                                              *|
|*      rank_idx - ir idx to subscript opr that creates the rank.             *|
|*      dope_idx - idx to dv_deref_opr if there is one.                       *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void make_base_subtree(opnd_type  *old_opnd,
                       opnd_type  *new_opnd,
                       int        *rank_idx,
                       int        *dope_idx)

{
   int		col;
   int          dummy_idx;
   fld_type     fld;
   int          idx;
   int		line;
   int          list_idx;
   int          list2_idx;
   int          new_root = NULL_IDX;
   opnd_type    n_opnd;
   opnd_type    o_opnd;


   TRACE (Func_Entry, "make_base_subtree", NULL);

   find_opnd_line_and_column(old_opnd, &line, &col);

   OPND_FLD((*new_opnd)) = OPND_FLD((*old_opnd));
   idx = OPND_IDX((*old_opnd));
   fld = OPND_FLD((*old_opnd));
   

   if (idx != NULL_IDX) {

      switch(fld) {

         case NO_Tbl_Idx   :
            break;

         case IR_Tbl_Idx :

            if (IR_OPR(idx) == Triplet_Opr) {
               COPY_OPND(o_opnd, IL_OPND(IR_IDX_L(idx)));
               make_base_subtree(&o_opnd, new_opnd, rank_idx, &dummy_idx);
               goto SKIP;
            }
            else if (IR_OPR(idx) == Call_Opr) {
               /* don't process a call and it's arguments. This means that */
               /* make_base_subtree was called before deferred function    */
               /* flattening occured.                                      */

               new_root = idx;
            }
            else {

               NTR_IR_TBL(new_root);

               COPY_TBL_NTRY(ir_tbl, new_root, idx);

               /* assume that all ir is now scalar */
               IR_RANK(new_root) = 0;

               if (IR_OPR(new_root) == Whole_Subscript_Opr    ||
                   IR_OPR(new_root) == Section_Subscript_Opr) {

                  if (*rank_idx != NULL_IDX) {
                     PRINTMSG(IR_LINE_NUM(idx), 545, Internal, IR_COL_NUM(idx));
                  }
                  *rank_idx = idx;

                  IR_OPR(new_root)  = Subscript_Opr;
               }
               else if (IR_OPR(idx) == Dv_Deref_Opr &&
                        *dope_idx   == NULL_IDX)    {
                  *dope_idx = idx;
               }

               COPY_OPND(o_opnd, IR_OPND_L(idx));
               make_base_subtree(&o_opnd, &n_opnd, rank_idx, dope_idx);
               COPY_OPND(IR_OPND_L(new_root), n_opnd);

               COPY_OPND(o_opnd, IR_OPND_R(idx));
               make_base_subtree(&o_opnd, &n_opnd, rank_idx, &dummy_idx);
               COPY_OPND(IR_OPND_R(new_root), n_opnd);
            }

            break;

         case AT_Tbl_Idx :
         case CN_Tbl_Idx :

            new_root = idx;
            OPND_LINE_NUM((*new_opnd)) = line;
            OPND_COL_NUM((*new_opnd))  = col;
            break;

         case IL_Tbl_Idx :

            NTR_IR_LIST_TBL(new_root);
            COPY_TBL_NTRY(ir_list_tbl, new_root, idx);
            OPND_LIST_CNT((*new_opnd)) = OPND_LIST_CNT((*old_opnd));
            COPY_OPND(o_opnd, IL_OPND(idx));
            make_base_subtree(&o_opnd, &n_opnd, rank_idx, &dummy_idx);
            COPY_OPND(IL_OPND(new_root), n_opnd);
            list2_idx        = new_root;
            idx              = IL_NEXT_LIST_IDX(idx);

            while (idx != NULL_IDX) {
               NTR_IR_LIST_TBL(list_idx);
               COPY_TBL_NTRY(ir_list_tbl, list_idx, idx);

               if (! IL_ARG_DESC_VARIANT(list_idx)) {
                  IL_PREV_LIST_IDX(list_idx)  = list2_idx;
               }
               IL_NEXT_LIST_IDX(list2_idx) = list_idx;
               list2_idx                   = list_idx;

               COPY_OPND(o_opnd, IL_OPND(idx));
               make_base_subtree(&o_opnd, &n_opnd, rank_idx, &dummy_idx);
               COPY_OPND(IL_OPND(list_idx), n_opnd);
               idx              = IL_NEXT_LIST_IDX(idx);
            }
            break;
      }
   }

   OPND_IDX((*new_opnd)) = new_root;
   OPND_FLD((*new_opnd)) = fld;

SKIP:

   TRACE (Func_Exit, "make_base_subtree", NULL);

   return;

}  /* make_base_subtree */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Finds the subcript opr that describes the section of an array         *|
|*      section reference and the Dv_Deref_Opr ir idx if there is one.        *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      old_opnd - root of original tree.                                     *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      rank_idx - idx of subscript opr that is the section.                  *|
|*      dope_idx - idx of deref opr if there is one.                          *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

static void just_find_dope_and_rank(opnd_type  *old_opnd,
                                    int        *rank_idx,
                                    int        *dope_idx)

{
   opnd_type    opnd;

   TRACE (Func_Entry, "just_find_dope_and_rank", NULL);

   COPY_OPND(opnd, (*old_opnd));

   while (OPND_FLD(opnd) == IR_Tbl_Idx) {

      if (IR_OPR(OPND_IDX(opnd)) == Section_Subscript_Opr ||
          IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr)  {

         if (*rank_idx != NULL_IDX) {
            PRINTMSG(IR_LINE_NUM(OPND_IDX(opnd)), 545, Internal,
                     IR_COL_NUM(OPND_IDX(opnd)));
         }
         *rank_idx = OPND_IDX(opnd);
      }
      else if (IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr &&
               *dope_idx              == NULL_IDX)    {
         *dope_idx = OPND_IDX(opnd);
      }

      COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
   }

   TRACE (Func_Exit, "just_find_dope_and_rank", NULL);

   return;

}  /* just_find_dope_and_rank */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void process_deferred_functions(opnd_type	*opnd)

{
   int		col;
   int		ir_idx;
   int		line;
   int		list_idx;
   opnd_type	loc_opnd;
   int		save_curr_stmt_sh_idx;
   int		sh_idx;

   TRACE (Func_Entry, "process_deferred_functions", NULL);

   find_opnd_line_and_column(opnd, &line, &col);

   switch (OPND_FLD((*opnd))) {
   case IR_Tbl_Idx:

      ir_idx = OPND_IDX((*opnd));

      if (IR_OPR(ir_idx) == Stmt_Expansion_Opr) {
# ifdef _DEBUG
         if (IR_FLD_L(ir_idx) == NO_Tbl_Idx) {
            PRINTMSG(IR_LINE_NUM(ir_idx), 626, Internal, IR_COL_NUM(ir_idx),
                     "no dags", "process_deferred_functions");
         }
# endif
         if (STMT_EXPAND_BEFORE_START_SH(ir_idx)) {

            OPND_FLD(loc_opnd) = SH_Tbl_Idx;
            OPND_IDX(loc_opnd) = STMT_EXPAND_BEFORE_START_SH(ir_idx);
            save_curr_stmt_sh_idx = curr_stmt_sh_idx;
            curr_stmt_sh_idx = STMT_EXPAND_BEFORE_START_SH(ir_idx);
            process_deferred_functions(&loc_opnd);
            curr_stmt_sh_idx = save_curr_stmt_sh_idx;

            sh_idx = STMT_EXPAND_BEFORE_START_SH(ir_idx);
            while (SH_PREV_IDX(sh_idx)) {
               sh_idx = SH_PREV_IDX(sh_idx);
            }
            STMT_EXPAND_BEFORE_START_SH(ir_idx) = sh_idx;

            sh_idx = STMT_EXPAND_BEFORE_END_SH(ir_idx);
            while (SH_NEXT_IDX(sh_idx)) {
               sh_idx = SH_NEXT_IDX(sh_idx);
            }
            STMT_EXPAND_BEFORE_END_SH(ir_idx) = sh_idx;

            insert_sh_chain(STMT_EXPAND_BEFORE_START_SH(ir_idx),
                            STMT_EXPAND_BEFORE_END_SH(ir_idx),
                            Before);
         }

         if (STMT_EXPAND_AFTER_START_SH(ir_idx)) {

            OPND_FLD(loc_opnd) = SH_Tbl_Idx;
            OPND_IDX(loc_opnd) = STMT_EXPAND_AFTER_START_SH(ir_idx);
            save_curr_stmt_sh_idx = curr_stmt_sh_idx;
            curr_stmt_sh_idx = STMT_EXPAND_AFTER_START_SH(ir_idx);
            process_deferred_functions(&loc_opnd);
            curr_stmt_sh_idx = save_curr_stmt_sh_idx;

            sh_idx = STMT_EXPAND_AFTER_START_SH(ir_idx);
            while (SH_PREV_IDX(sh_idx)) {
               sh_idx = SH_PREV_IDX(sh_idx);
            }
            STMT_EXPAND_AFTER_START_SH(ir_idx) = sh_idx;

            sh_idx = STMT_EXPAND_AFTER_END_SH(ir_idx);
            while (SH_NEXT_IDX(sh_idx)) {
               sh_idx = SH_NEXT_IDX(sh_idx);
            }
            STMT_EXPAND_AFTER_END_SH(ir_idx) = sh_idx;

            insert_sh_chain(STMT_EXPAND_AFTER_START_SH(ir_idx),
                            STMT_EXPAND_AFTER_END_SH(ir_idx),
                            After);
         }

         COPY_OPND((*opnd), IR_OPND_L(ir_idx));
         IR_OPND_L(ir_idx) = null_opnd;
/*
         free_stmt_expansion_opr(ir_idx);
*/
      }
      else {
	 if (IR_FLD_L(ir_idx) != SH_Tbl_Idx) {
	    process_deferred_functions(&IR_OPND_L(ir_idx));
	 }

	 if (IR_FLD_R(ir_idx) != SH_Tbl_Idx) {
	    process_deferred_functions(&IR_OPND_R(ir_idx));
	 }
      }
      break;

   case SH_Tbl_Idx:
      save_curr_stmt_sh_idx = curr_stmt_sh_idx;
      curr_stmt_sh_idx = OPND_IDX((*opnd));

      while (curr_stmt_sh_idx != NULL_IDX) {
         OPND_FLD(loc_opnd) = IR_Tbl_Idx;
         OPND_IDX(loc_opnd) = SH_IR_IDX(curr_stmt_sh_idx);
         process_deferred_functions(&loc_opnd);
         SH_IR_IDX(curr_stmt_sh_idx) = OPND_IDX(loc_opnd);
         curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
      }
      curr_stmt_sh_idx = save_curr_stmt_sh_idx;
      break;

   case IL_Tbl_Idx:
      list_idx = OPND_IDX((*opnd));
      while (list_idx) {
	 if (IL_FLD(list_idx) != SH_Tbl_Idx) {
	     process_deferred_functions(&IL_OPND(list_idx));
	 }
         list_idx = IL_NEXT_LIST_IDX(list_idx);
      }
      break;

   }

   TRACE (Func_Exit, "process_deferred_functions", NULL);

   return;

}  /* process_deferred_functions */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Perform short circuiting on Br_True_Opr stmts.                        *|
|*      Assumes that curr_stmt_sh_idx is the branch stmt.                     *|
|*      This routine is only called when there was a function encountered     *|
|*      in the condition, so process_deferred_functions must always be called *|
|*      whether short circuiting is done or not.                              *|
|*      The top operator (after NOT is de'morganed) must be logical .and. or  *|
|*      .or. in order for this routine to short circuit.                      *|
|*      The "opt" setting must be considered here to possibly prevent         *|
|*      any short circuiting.                                                 *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void    short_circuit_branch(void)

{
   int		asg_idx;
   int          br_true_idx;
   int		col;
   int          ir_idx;
   int		label_idx;
   boolean	left_is_worse;
   int		line;
   int		log_idx;
   int          not_cnt		= 0;
   int		not_idx;
   opnd_type    not_opnd;
   opnd_type    opnd;
   int		opnd_column;
   int		opnd_line;
   int          save_curr_stmt_sh_idx;
   int		tmp_idx;


   TRACE (Func_Entry, "short_circuit_branch", NULL);

   br_true_idx = SH_IR_IDX(curr_stmt_sh_idx);

   line = IR_LINE_NUM(br_true_idx);
   col  = IR_COL_NUM(br_true_idx);

   COPY_OPND(opnd, IR_OPND_L(br_true_idx));

   while (OPND_FLD(opnd) == IR_Tbl_Idx) {

      switch(IR_OPR(OPND_IDX(opnd))) {
         case Not_Opr:
            not_cnt++;

            if (not_cnt == 1) {
               COPY_OPND(not_opnd, opnd);
            }
            COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
            break;

         case Or_Opr:
         case And_Opr:

            log_idx = OPND_IDX(opnd);

            if (IR_SHORT_CIRCUIT_L(log_idx)) {
               left_is_worse = TRUE;
            }
# if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
            else {
               left_is_worse = FALSE;
            }
# else
/* in case we change our minds about short circuiting decisions, save this */
            else if (IR_SHORT_CIRCUIT_R(log_idx)) {
               left_is_worse = FALSE;
            }
            else {
               /* no more functions below this operator. */
               if (not_cnt%2 == 0) {
                  /* nots cancel out */
                  COPY_OPND(IR_OPND_L(br_true_idx), opnd);
               }
               else {
                  COPY_OPND(IR_OPND_L(OPND_IDX(not_opnd)), opnd);
                  COPY_OPND(IR_OPND_L(br_true_idx), not_opnd);
               }
               goto OUT;
            }
# endif

            if (not_cnt%2 == 0) {
               /* nots cancel out */
               COPY_OPND(IR_OPND_L(br_true_idx), opnd);
            }
            else {
               /* demorgan it */
               COPY_OPND(IR_OPND_L(br_true_idx), opnd);

               if (IR_OPR(log_idx) == Or_Opr) {
                  IR_OPR(log_idx) = And_Opr;
               }
               else {
                  IR_OPR(log_idx) = Or_Opr;
               }
               COPY_OPND(IR_OPND_L(OPND_IDX(not_opnd)), 
                         IR_OPND_L(log_idx));
               COPY_OPND(IR_OPND_L(log_idx), not_opnd);

               NTR_IR_TBL(ir_idx);
               IR_OPR(ir_idx) = Not_Opr;
               IR_TYPE_IDX(ir_idx) = LOGICAL_DEFAULT_TYPE;
               IR_LINE_NUM(ir_idx) = IR_LINE_NUM(OPND_IDX(not_opnd));
               IR_COL_NUM(ir_idx)  = IR_COL_NUM(OPND_IDX(not_opnd));
               COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(log_idx));
               IR_FLD_R(log_idx) = IR_Tbl_Idx;
               IR_IDX_R(log_idx) = ir_idx;
            }

            if (IR_OPR(log_idx) == Or_Opr) {

               /* split condition, share label */

               gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);

               NTR_IR_TBL(ir_idx);
               IR_OPR(ir_idx)      = Br_True_Opr;
               IR_TYPE_IDX(ir_idx) = LOGICAL_DEFAULT_TYPE;
               IR_LINE_NUM(ir_idx) = line;
               IR_COL_NUM(ir_idx)  = col;


               /* Brian:  This is from s_end.c.	 If I'm wrong about needing   */
               /* the temp, let me know and I'll get rid of it in both places.*/
               /* If we're working on an IF construct expression, transfer the*/
               /* branch-around label to the right operand of the Br_True IR  */
               /* (replacing the IL list).  The IL_OPND is copied to a temp   */
               /* first because sometimes assignments get a little funky      */
               /* using these macros if the target is also being used to      */
               /* access the source.				              */
               /* If we're getting tight on space, could also delete the IL   */
               /* nodes. 						      */

               if (IR_FLD_R(br_true_idx) == IL_Tbl_Idx) {
                  COPY_OPND(opnd, IL_OPND(IR_IDX_R(br_true_idx)));
                  COPY_OPND(IR_OPND_R(ir_idx), opnd);
               }
               else {
                  COPY_OPND(IR_OPND_R(ir_idx), IR_OPND_R(br_true_idx));
               }


               if (left_is_worse) {
                  COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(log_idx));
                  COPY_OPND(IR_OPND_L(br_true_idx), IR_OPND_L(log_idx));
               }
               else {
                  COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(log_idx));
                  COPY_OPND(IR_OPND_L(br_true_idx), IR_OPND_R(log_idx));
               }

               save_curr_stmt_sh_idx = curr_stmt_sh_idx;
               curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);

               SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
               SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

               short_circuit_branch(); 

               curr_stmt_sh_idx = save_curr_stmt_sh_idx;

               short_circuit_branch();
            }
            else {

               /* generate label */
               label_idx = gen_internal_lbl(stmt_start_line);

               gen_sh(After, Continue_Stmt, line, col, FALSE, TRUE, TRUE);

               NTR_IR_TBL(ir_idx);
               SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
               IR_OPR(ir_idx)              = Label_Opr;
               IR_TYPE_IDX(ir_idx)         = TYPELESS_DEFAULT_TYPE;
               IR_LINE_NUM(ir_idx)         = line;
               IR_COL_NUM(ir_idx)          = col;
               IR_FLD_L(ir_idx)            = AT_Tbl_Idx;
               IR_IDX_L(ir_idx)            = label_idx;
               AT_REFERENCED(label_idx)    = Referenced;
               IR_COL_NUM_L(ir_idx)        = col;
               IR_LINE_NUM_L(ir_idx)       = line;

               AT_DEFINED(label_idx)       = TRUE;
               ATL_DEF_STMT_IDX(label_idx) = curr_stmt_sh_idx;

               SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
               curr_stmt_sh_idx                = SH_PREV_IDX(curr_stmt_sh_idx);

               NTR_IR_TBL(ir_idx);
               IR_OPR(ir_idx)        = Br_True_Opr;
               IR_TYPE_IDX(ir_idx)   = LOGICAL_DEFAULT_TYPE;
               IR_LINE_NUM(ir_idx)   = line;
               IR_COL_NUM(ir_idx)    = col;
               IR_FLD_R(ir_idx)      = AT_Tbl_Idx;
               IR_IDX_R(ir_idx)      = label_idx;
               IR_LINE_NUM_R(ir_idx) = line;
               IR_COL_NUM_R(ir_idx)  = col;

               NTR_IR_TBL(not_idx);
               IR_OPR(not_idx)       = Not_Opr;
               IR_TYPE_IDX(not_idx)  = LOGICAL_DEFAULT_TYPE;
               IR_LINE_NUM(not_idx)  = line;
               IR_COL_NUM(not_idx)   = col;
               IR_FLD_L(ir_idx)      = IR_Tbl_Idx;
               IR_IDX_L(ir_idx)      = not_idx;

               if (left_is_worse) {
                  COPY_OPND(IR_OPND_L(not_idx), IR_OPND_R(log_idx));
                  COPY_OPND(IR_OPND_L(br_true_idx), IR_OPND_L(log_idx));
               }
               else {
                  COPY_OPND(IR_OPND_L(not_idx), IR_OPND_L(log_idx));
                  COPY_OPND(IR_OPND_L(br_true_idx), IR_OPND_R(log_idx));
               }
               
               gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);

               save_curr_stmt_sh_idx = curr_stmt_sh_idx;
               curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);

               SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
               SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

               short_circuit_branch();

               curr_stmt_sh_idx = save_curr_stmt_sh_idx;

               short_circuit_branch();
            }

            goto EXIT;

         case Paren_Opr:
            COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
            break;

         default:
            if (not_cnt%2 == 0) {
               /* nots cancel out */
               COPY_OPND(IR_OPND_L(br_true_idx), opnd);
            }
            else {
               COPY_OPND(IR_OPND_L(OPND_IDX(not_opnd)), opnd);
               COPY_OPND(IR_OPND_L(br_true_idx), not_opnd);
            }

            goto OUT;
      }
   }

OUT:

   COPY_OPND(opnd, IR_OPND_L(br_true_idx));

   /* Brian:								      */
   /* Just a reminder that the following block of code was duped into         */
   /* if_stmt-semantics to avoid short-circuiting the IF conditional          */
   /* expression for the high-level form of IF requested by the Mongoose      */
   /* optimizer.					LRR Oct-Nov, 1997     */

   if (tree_produces_dealloc(&opnd)) { /* make logical tmp asg */
      save_curr_stmt_sh_idx = curr_stmt_sh_idx;
      find_opnd_line_and_column(&opnd, &opnd_line, &opnd_column);

      GEN_COMPILER_TMP_ASG(asg_idx,
                           tmp_idx,
                           TRUE,       /* Semantics done */
                           opnd_line,
                           opnd_column,
                           LOGICAL_DEFAULT_TYPE,
                           Priv);

      gen_sh(Before, Assignment_Stmt, opnd_line,
             opnd_column, FALSE, FALSE, TRUE);

      curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);

      SH_IR_IDX(curr_stmt_sh_idx)     = asg_idx;
      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

      process_deferred_functions(&opnd);
      COPY_OPND(IR_OPND_R(asg_idx), opnd);

      IR_FLD_L(br_true_idx)      = AT_Tbl_Idx;
      IR_IDX_L(br_true_idx)      = tmp_idx;
      IR_LINE_NUM_L(br_true_idx) = opnd_line;
      IR_COL_NUM_L(br_true_idx)  = opnd_column;
      curr_stmt_sh_idx           = save_curr_stmt_sh_idx;
   }
   else {
      process_deferred_functions(&opnd);
      COPY_OPND(IR_OPND_L(br_true_idx), opnd);
   }


EXIT:

   TRACE (Func_Exit, "short_circuit_branch", NULL);

   return;

}  /* short_circuit_branch */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Search a subtree to see if it has a variable size function call or    *|
|*      a run time constructor, or dope vector result intrinsic.              *|
|*      All of these produce some sort of dealloc stmt (or stmts) after       *|
|*      the current stmt. The result of the tree must be pulled into a        *|
|*      logical tmp if this routine returns TRUE so that the dealloc          *|
|*      stmts are executed before any branch occurs.                          *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

boolean tree_produces_dealloc(opnd_type	*root)

{
   int		i;
   int		list_idx;
   opnd_type    opnd;
   boolean 	has_dealloc = FALSE;


   TRACE (Func_Entry, "tree_produces_dealloc", NULL);

   if (OPND_FLD((*root)) == IR_Tbl_Idx) {

      if (IR_OPR(OPND_IDX((*root))) == Stmt_Expansion_Opr) {

         if (STMT_EXPAND_AFTER_START_SH(OPND_IDX((*root))) != NULL_IDX) {
            has_dealloc = TRUE;
         }
      }
      else if (IR_OPR(OPND_IDX((*root))) == Array_Construct_Opr ||
               IR_OPR(OPND_IDX((*root))) == Adjustl_Opr         ||
               IR_OPR(OPND_IDX((*root))) == Adjustr_Opr)        {

         has_dealloc = TRUE;
         goto EXIT;
      }
      else {

         if (IR_FLD_L(OPND_IDX((*root))) == IR_Tbl_Idx ||
             IR_FLD_L(OPND_IDX((*root))) == IL_Tbl_Idx) {

            COPY_OPND(opnd, IR_OPND_L(OPND_IDX((*root))));
            has_dealloc = tree_produces_dealloc(&opnd);

            if (has_dealloc) {
               goto EXIT;
            }
         }

         if (IR_FLD_R(OPND_IDX((*root))) == IR_Tbl_Idx ||
             IR_FLD_R(OPND_IDX((*root))) == IL_Tbl_Idx) {

            COPY_OPND(opnd, IR_OPND_R(OPND_IDX((*root))));
            has_dealloc = tree_produces_dealloc(&opnd);

            if (has_dealloc) {
               goto EXIT;
            }
         }
      }
   }
   else if (OPND_FLD((*root)) == IL_Tbl_Idx) {

      list_idx = OPND_IDX((*root));
 
      for (i = 0; i < OPND_LIST_CNT((*root)); i++) {

         if (IL_FLD(list_idx) == IR_Tbl_Idx ||
             IL_FLD(list_idx) == IL_Tbl_Idx) {

            COPY_OPND(opnd, IL_OPND(list_idx));
            has_dealloc = tree_produces_dealloc(&opnd);

            if (has_dealloc) {
               goto EXIT;
            }
         }

         list_idx = IL_NEXT_LIST_IDX(list_idx);
      }
   }

EXIT:

   TRACE (Func_Exit, "tree_produces_dealloc", NULL);

   return(has_dealloc);

}  /* tree_produces_dealloc */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void create_loop_stmts(int		lcv_attr,
		       opnd_type       *start_opnd,
		       opnd_type       *end_opnd,
		       opnd_type       *inc_opnd,
		       int		body_start_sh_idx,
		       int		body_end_sh_idx)

{
   int		       col;
   int		       ir_idx;
   int		       line;
   int		       save_curr_stmt_sh_idx;

# if !defined(_HIGH_LEVEL_DO_LOOP_FORM)
   int		       asg_idx;
   int		       br_around_label;
   int		       br_back_label;
   int		       div_idx;
   opnd_type	       end_tmp_opnd;
   expr_arg_type       exp_desc;
   opnd_type	       inc_tmp_opnd;
   int		       log_idx;
   int		       minus_idx;
   int		       mult_idx;
   opnd_type           opnd;
   int		       opnd_col;
   int		       opnd_line;
   int		       plus_idx;
   cif_usage_code_type save_xref_state;
   opnd_type	       start_tmp_opnd;
   int		       tmp_idx;
   opnd_type	       trip_count_tmp_opnd;
   opnd_type	       trip_counter_tmp_opnd;
# else
   int		       list_idx;
   int		       list_idx2;
# endif


   TRACE (Func_Entry, "create_loop_stmts", NULL);

   save_curr_stmt_sh_idx = curr_stmt_sh_idx;

   line = stmt_start_line;
   col  = stmt_start_col;

# if defined(_HIGH_LEVEL_DO_LOOP_FORM)
   curr_stmt_sh_idx = body_end_sh_idx;

   ir_idx = gen_ir(NO_Tbl_Idx, NULL_IDX,
               Loop_End_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                   NO_Tbl_Idx, NULL_IDX);

   gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE);
   SH_IR_IDX(curr_stmt_sh_idx)     = ir_idx;
   SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
   SH_LOOP_END(curr_stmt_sh_idx) = TRUE;

   curr_stmt_sh_idx = body_start_sh_idx;

   NTR_IR_LIST_TBL(list_idx);
   gen_opnd(&IL_OPND(list_idx), lcv_attr, AT_Tbl_Idx, line, col);

   NTR_IR_LIST_TBL(list_idx2);
   IL_NEXT_LIST_IDX(list_idx) = list_idx2;
   IL_PREV_LIST_IDX(list_idx2) = list_idx;

   COPY_OPND(IL_OPND(list_idx2), (*start_opnd));

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
   list_idx2 = IL_NEXT_LIST_IDX(list_idx2);

   COPY_OPND(IL_OPND(list_idx2), (*end_opnd));

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
   list_idx2 = IL_NEXT_LIST_IDX(list_idx2);

   COPY_OPND(IL_OPND(list_idx2), (*inc_opnd));


   ir_idx = gen_ir(SH_Tbl_Idx, SH_NEXT_IDX(body_end_sh_idx),
               Loop_Info_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                   IL_Tbl_Idx, list_idx);

   gen_sh(Before, Do_Iterative_Stmt, line, col, FALSE, FALSE, TRUE);
   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = ir_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   SH_PARENT_BLK_IDX(SH_NEXT_IDX(body_end_sh_idx)) = 
                                           SH_PREV_IDX(curr_stmt_sh_idx);

# else
   /***************************************************************************\
   |* branch around label. Do this first.                                     *|
   \***************************************************************************/

   curr_stmt_sh_idx = body_end_sh_idx;

   br_around_label = gen_internal_lbl(line);

   ir_idx = gen_ir(AT_Tbl_Idx, br_around_label,
               Label_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                   NO_Tbl_Idx, NULL_IDX);

   gen_sh(After, Continue_Stmt, line, col, FALSE, TRUE, TRUE);
   SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;

   AT_DEFINED(br_around_label)       = TRUE;
   ATL_DEF_STMT_IDX(br_around_label) = curr_stmt_sh_idx;

   SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;


   /***************************************************************************\
   |***************************************************************************|
   |**                        PREFIX CODE                                    **|
   |***************************************************************************|
   \***************************************************************************/

   curr_stmt_sh_idx = body_start_sh_idx;


   /***************************************************************************\
   |* temp = start value                                                      *|
   \***************************************************************************/

   if (OPND_FLD((*start_opnd)) == CN_Tbl_Idx &&
       TYP_LINEAR(CN_TYPE_IDX(OPND_IDX((*start_opnd)))) == 
                                                       Short_Typeless_Const) {

      find_opnd_line_and_column(start_opnd, &opnd_line, &opnd_col);
      OPND_IDX((*start_opnd)) = cast_typeless_constant(OPND_IDX((*start_opnd)),
                                                       ATD_TYPE_IDX(lcv_attr),
                                                       opnd_line,
                                                       opnd_col);
   }

   if (OPND_FLD((*start_opnd)) == CN_Tbl_Idx ||
       (OPND_FLD((*start_opnd)) == AT_Tbl_Idx &&
        ATD_CLASS(OPND_IDX((*start_opnd))) == Compiler_Tmp)) {

      COPY_OPND(start_tmp_opnd, (*start_opnd));
   }
   else {

      GEN_COMPILER_TMP_ASG(asg_idx,
                           tmp_idx,
                           TRUE,	/* Semantics done */
                           line,
                           col,
                           ATD_TYPE_IDX(lcv_attr),
                           Priv);

      COPY_OPND(IR_OPND_R(asg_idx), (*start_opnd));

      gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

      gen_opnd(&start_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col);
   }
   
   /***************************************************************************\
   |* temp = end value                                                        *|
   \***************************************************************************/

   if (OPND_FLD((*end_opnd)) == CN_Tbl_Idx &&
       TYP_LINEAR(CN_TYPE_IDX(OPND_IDX((*end_opnd)))) ==
                                                       Short_Typeless_Const) {

      find_opnd_line_and_column(end_opnd, &opnd_line, &opnd_col);
      OPND_IDX((*end_opnd)) = cast_typeless_constant(OPND_IDX((*end_opnd)),
                                                       ATD_TYPE_IDX(lcv_attr),
                                                       opnd_line,
                                                       opnd_col);
   }

   if (OPND_FLD((*end_opnd)) == CN_Tbl_Idx ||
       (OPND_FLD((*end_opnd)) == AT_Tbl_Idx &&
        ATD_CLASS(OPND_IDX((*end_opnd))) == Compiler_Tmp)) {

      COPY_OPND(end_tmp_opnd, (*end_opnd));
   }
   else {

      GEN_COMPILER_TMP_ASG(asg_idx,
                           tmp_idx,
                           TRUE,	/* Semantics done */
                           line,
                           col,
                           ATD_TYPE_IDX(lcv_attr),
                           Priv);

      COPY_OPND(IR_OPND_R(asg_idx), (*end_opnd));

      gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

      gen_opnd(&end_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col);
   }

   /***************************************************************************\
   |* temp = increment value                                                  *|
   \***************************************************************************/

   if (OPND_FLD((*inc_opnd)) == CN_Tbl_Idx &&
       TYP_LINEAR(CN_TYPE_IDX(OPND_IDX((*inc_opnd)))) ==
                                                       Short_Typeless_Const) {

      find_opnd_line_and_column(inc_opnd, &opnd_line, &opnd_col);
      OPND_IDX((*inc_opnd)) = cast_typeless_constant(OPND_IDX((*inc_opnd)),
                                                       ATD_TYPE_IDX(lcv_attr),
                                                       opnd_line,
                                                       opnd_col);
   }

   if (OPND_FLD((*inc_opnd)) == CN_Tbl_Idx ||
       (OPND_FLD((*inc_opnd)) == AT_Tbl_Idx &&
        ATD_CLASS(OPND_IDX((*inc_opnd))) == Compiler_Tmp)) {

      COPY_OPND(inc_tmp_opnd, (*inc_opnd));
   }
   else {

      GEN_COMPILER_TMP_ASG(asg_idx,
                           tmp_idx,
                           TRUE,	/* Semantics done */
                           line,
                           col,
                           ATD_TYPE_IDX(lcv_attr),
                           Priv);

      COPY_OPND(IR_OPND_R(asg_idx), (*inc_opnd));

      gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

      gen_opnd(&inc_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col);
   }

   /***************************************************************************\
   |* lcv attr = start temp                                                   *|
   \***************************************************************************/

   asg_idx = gen_ir(AT_Tbl_Idx, lcv_attr,
               Asg_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
                    OPND_FLD(start_tmp_opnd), OPND_IDX(start_tmp_opnd));

   gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   /***************************************************************************\
   |* temp = trip count expression. ((end - start) + inc)/inc                 *|
   \***************************************************************************/


   minus_idx = gen_ir(OPND_FLD(end_tmp_opnd), OPND_IDX(end_tmp_opnd),
                 Minus_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
                      OPND_FLD(start_tmp_opnd), OPND_IDX(start_tmp_opnd));

   plus_idx = gen_ir(IR_Tbl_Idx, minus_idx,
                 Plus_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
                     OPND_FLD(inc_tmp_opnd), OPND_IDX(inc_tmp_opnd));

   div_idx = gen_ir(IR_Tbl_Idx, plus_idx,
                 Div_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
                    OPND_FLD(inc_tmp_opnd), OPND_IDX(inc_tmp_opnd));

   OPND_FLD(opnd) = IR_Tbl_Idx;
   OPND_IDX(opnd) = div_idx;

   save_xref_state = xref_state;
   xref_state      = CIF_No_Usage_Rec;
   expr_semantics(&opnd, &exp_desc);
   xref_state      = save_xref_state;

   if (OPND_FLD(opnd) == CN_Tbl_Idx ||
       (OPND_FLD(opnd) == AT_Tbl_Idx &&
        ATD_CLASS(OPND_IDX(opnd)) == Compiler_Tmp)) {

      COPY_OPND(trip_count_tmp_opnd, opnd);
   }
   else {

      GEN_COMPILER_TMP_ASG(asg_idx,
                           tmp_idx,
                           TRUE,	/* Semantics done */
                           line,
                           col,
                           exp_desc.type_idx,
                           Priv);

      COPY_OPND(IR_OPND_R(asg_idx), opnd);

      gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
   
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

      gen_opnd(&trip_count_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col);
   }


   /***************************************************************************\
   |* branch around test for trip count <= 0                                  *|
   \***************************************************************************/

   log_idx = gen_ir(OPND_FLD(trip_count_tmp_opnd),OPND_IDX(trip_count_tmp_opnd),
                Le_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                    CN_Tbl_Idx, CN_INTEGER_ZERO_IDX);

   ir_idx = gen_ir(IR_Tbl_Idx, log_idx,
               Br_True_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                   AT_Tbl_Idx, br_around_label);

   gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = ir_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   /***************************************************************************\
   |* trip counter temp = 0                                                   *|
   \***************************************************************************/

   GEN_COMPILER_TMP_ASG(asg_idx,
                        tmp_idx,
                        TRUE,	/* Semantics done */
                        line,
                        col,
                        CG_INTEGER_DEFAULT_TYPE,
                        Priv);

   gen_opnd(&IR_OPND_R(asg_idx), CN_INTEGER_ZERO_IDX, CN_Tbl_Idx, line, col);

   gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   gen_opnd(&trip_counter_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col);

   /***************************************************************************\
   |* branch back label                                                       *|
   \***************************************************************************/

   br_back_label = gen_internal_lbl(line);

   ir_idx = gen_ir(AT_Tbl_Idx, br_back_label,
               Label_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                   NO_Tbl_Idx, NULL_IDX);

   gen_sh(Before, Continue_Stmt, line, col, FALSE, TRUE, TRUE);
   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;

   AT_DEFINED(br_back_label)       = TRUE;
   ATL_DEF_STMT_IDX(br_back_label) = SH_PREV_IDX(curr_stmt_sh_idx);

   if (in_constructor) {
      ATL_CONSTRUCTOR_LOOP(br_back_label) = TRUE;
   }

   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   /***************************************************************************\
   |* lcv attr = start temp + (trip counter temp * increment temp)            *|
   \***************************************************************************/

   mult_idx = gen_ir(OPND_FLD(trip_counter_tmp_opnd), 
                                     OPND_IDX(trip_counter_tmp_opnd),
                 Mult_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
                     OPND_FLD(inc_tmp_opnd), OPND_IDX(inc_tmp_opnd));

   plus_idx = gen_ir(OPND_FLD(start_tmp_opnd), OPND_IDX(start_tmp_opnd),
                 Plus_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
                     IR_Tbl_Idx, mult_idx);

   asg_idx = gen_ir(AT_Tbl_Idx, lcv_attr,
                Asg_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
                    IR_Tbl_Idx, plus_idx);

   gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;



   /***************************************************************************\
   |***************************************************************************|
   |**                        SUFFIX CODE                                    **|
   |***************************************************************************|
   \***************************************************************************/

   curr_stmt_sh_idx = body_end_sh_idx;

   /***************************************************************************\
   |* trip counter temp = trip counter temp + 1                               *|
   \***************************************************************************/

   plus_idx = gen_ir(OPND_FLD(trip_counter_tmp_opnd), 
                                  OPND_IDX(trip_counter_tmp_opnd),
                 Plus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                     CN_Tbl_Idx, CN_INTEGER_ONE_IDX);

   asg_idx = gen_ir(OPND_FLD(trip_counter_tmp_opnd), 
                                  OPND_IDX(trip_counter_tmp_opnd),
                Asg_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                    IR_Tbl_Idx, plus_idx);

   gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
   SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
   SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

   /***************************************************************************\
   |* branch back test for trip counter temp < trip count                     *|
   \***************************************************************************/

   log_idx = gen_ir(OPND_FLD(trip_counter_tmp_opnd),
                             OPND_IDX(trip_counter_tmp_opnd),
                Lt_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                   OPND_FLD(trip_count_tmp_opnd),OPND_IDX(trip_count_tmp_opnd));

   ir_idx = gen_ir(IR_Tbl_Idx, log_idx,
               Br_True_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                   AT_Tbl_Idx, br_back_label);

   gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   SH_IR_IDX(curr_stmt_sh_idx)     = ir_idx;
   SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;


   /***************************************************************************\
   |* lcv attr = start temp + (trip count temp * increment temp)              *|
   \***************************************************************************/

   mult_idx =gen_ir(OPND_FLD(trip_count_tmp_opnd),OPND_IDX(trip_count_tmp_opnd),
                 Mult_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
                     OPND_FLD(inc_tmp_opnd), OPND_IDX(inc_tmp_opnd));

   plus_idx = gen_ir(OPND_FLD(start_tmp_opnd), OPND_IDX(start_tmp_opnd),
                 Plus_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
                     IR_Tbl_Idx, mult_idx);

   asg_idx = gen_ir(AT_Tbl_Idx, lcv_attr,
                Asg_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
                    IR_Tbl_Idx, plus_idx);

   gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   SH_IR_IDX(curr_stmt_sh_idx)     = asg_idx;
   SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

# endif


   curr_stmt_sh_idx = save_curr_stmt_sh_idx;

   TRACE (Func_Exit, "create_loop_stmts", NULL);

   return;

}  /* create_loop_stmts */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Create an array bounds table entry from an expr_arg_type arg          *|
|*      All bounds info must be constant.                                     *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

int	create_bd_ntry_for_const(expr_arg_type	*exp_desc,
                                 int		 line,
				 int		 col)

{
   int			bd_idx;
   size_offset_type	extent;
   int			i;
   size_offset_type	num_elements;
   size_offset_type	stride;


   TRACE (Func_Entry, "create_bd_ntry_for_const", NULL);

   bd_idx			= reserve_array_ntry(exp_desc->rank);
   BD_RANK(bd_idx)		= exp_desc->rank;
   BD_LINE_NUM(bd_idx)		= line;
   BD_COLUMN_NUM(bd_idx)	= col;
   BD_ARRAY_SIZE(bd_idx)	= Constant_Size;
   BD_ARRAY_CLASS(bd_idx)	= Explicit_Shape;
   BD_RESOLVED(bd_idx)		= TRUE;

   num_elements.idx	   	= CN_INTEGER_ONE_IDX;
   num_elements.fld		= CN_Tbl_Idx;

   for (i = 1; i <= exp_desc->rank; i++) {
      BD_LB_FLD(bd_idx,i) = CN_Tbl_Idx;
      BD_LB_IDX(bd_idx,i) = CN_INTEGER_ONE_IDX;

      if (OPND_FLD(exp_desc->shape[i-1]) == CN_Tbl_Idx) {
         BD_UB_FLD(bd_idx,i) = OPND_FLD(exp_desc->shape[i-1]);
         BD_UB_IDX(bd_idx,i) = OPND_IDX(exp_desc->shape[i-1]);
      }
      else {
         PRINTMSG(line, 966, Internal, col);
      }

      BD_XT_FLD(bd_idx,i) = BD_UB_FLD(bd_idx,i);
      BD_XT_IDX(bd_idx,i) = BD_UB_IDX(bd_idx,i);

      extent.fld	= BD_XT_FLD(bd_idx,i);
      extent.idx	= BD_XT_IDX(bd_idx,i);

      size_offset_binary_calc(&extent,
                              &num_elements,
                               Mult_Opr,
                              &num_elements);
   }

   if (num_elements.fld == NO_Tbl_Idx) {
      BD_LEN_FLD(bd_idx) = CN_Tbl_Idx;
      BD_LEN_IDX(bd_idx) = ntr_const_tbl(num_elements.type_idx,
                                         FALSE,
                                         num_elements.constant);
   }
   else {
      BD_LEN_FLD(bd_idx) = num_elements.fld;
      BD_LEN_IDX(bd_idx) = num_elements.idx;
   }

   /* fill in stride multipliers now */

   set_stride_for_first_dim(exp_desc->type_idx, &stride);

   BD_SM_FLD(bd_idx, 1) = stride.fld;
   BD_SM_IDX(bd_idx, 1) = stride.idx;

   for (i = 2; i <= BD_RANK(bd_idx); i++) {
      extent.fld	= BD_XT_FLD(bd_idx,i-1);
      extent.idx	= BD_XT_IDX(bd_idx,i-1);

      size_offset_binary_calc(&extent, &stride, Mult_Opr, &stride);

      if (stride.fld == NO_Tbl_Idx) {
         stride.fld	= CN_Tbl_Idx;
         stride.idx	= ntr_const_tbl(stride.type_idx,
                                        FALSE,
                                        stride.constant);
      }

      BD_SM_FLD(bd_idx, i)	= stride.fld;
      BD_SM_IDX(bd_idx, i)	= stride.idx;
   }

   bd_idx =  ntr_array_in_bd_tbl(bd_idx);

   TRACE (Func_Exit, "create_bd_ntry_for_const", NULL);

   return(bd_idx);

}  /* create_bd_ntry_for_const */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Fold the clen_opr if possible.                                        *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void fold_clen_opr(opnd_type		*opnd,
		   expr_arg_type	*exp_desc)

{
   int		attr_idx;
   int		clen_idx;
   int		col;
   int		ir_idx;
   int		line;
   int		list_idx;
   int		shift_idx;
   int		type_idx;


   TRACE (Func_Entry, "fold_clen_opr", NULL);

   find_opnd_line_and_column(opnd, &line, &col);

   if (OPND_FLD((*opnd)) != IR_Tbl_Idx ||
       IR_OPR(OPND_IDX((*opnd))) != Clen_Opr) {

      goto EXIT;
   }

   clen_idx = OPND_IDX((*opnd));

   exp_desc->type_idx    = IR_TYPE_IDX(clen_idx);
   exp_desc->type        = TYP_TYPE(exp_desc->type_idx);
   exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);

   switch (IR_FLD_L(clen_idx)) {
      case AT_Tbl_Idx :
         attr_idx = IR_IDX_L(clen_idx);

         if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
             (ATD_IM_A_DOPE(attr_idx)    ||
              ATD_POINTER(attr_idx)      ||
              ATD_ALLOCATABLE(attr_idx))) {

            if (char_len_in_bytes) {

               /* the length is already in bytes for solaris */

               NTR_IR_TBL(ir_idx);
               IR_OPR(ir_idx)           = Dv_Access_El_Len;
               IR_TYPE_IDX(ir_idx)      = SA_INTEGER_DEFAULT_TYPE;
               IR_LINE_NUM(ir_idx)      = line;
               IR_COL_NUM(ir_idx)       = col;
               COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(clen_idx));

               OPND_FLD((*opnd)) = IR_Tbl_Idx;
               OPND_IDX((*opnd)) = ir_idx;
            }
            else {

               /* must shift the bits to bytes */

               NTR_IR_TBL(ir_idx);
               IR_OPR(ir_idx)           = Dv_Access_El_Len;
               IR_TYPE_IDX(ir_idx)      = SA_INTEGER_DEFAULT_TYPE;
               IR_LINE_NUM(ir_idx)      = line;
               IR_COL_NUM(ir_idx)       = col;
               COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(clen_idx));
               NTR_IR_TBL(shift_idx);
               IR_OPR(shift_idx)        = Shiftr_Opr;
               IR_TYPE_IDX(shift_idx)   = SA_INTEGER_DEFAULT_TYPE;
               IR_LINE_NUM(shift_idx)   = line;
               IR_COL_NUM(shift_idx)    = col;

               NTR_IR_LIST_TBL(list_idx);
    
               IR_FLD_L(shift_idx)      = IL_Tbl_Idx;
               IR_IDX_L(shift_idx)      = list_idx;
               IR_LIST_CNT_L(shift_idx) = 2;
               IL_FLD(list_idx)         = IR_Tbl_Idx;
               IL_IDX(list_idx)         = ir_idx;

               NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
               IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
               list_idx = IL_NEXT_LIST_IDX(list_idx);

               IL_FLD(list_idx)      = CN_Tbl_Idx;
               IL_LINE_NUM(list_idx) = line;
               IL_COL_NUM(list_idx)  = col;
               IL_IDX(list_idx) = CN_INTEGER_THREE_IDX;
   
               OPND_FLD((*opnd)) = IR_Tbl_Idx;
               OPND_IDX((*opnd)) = shift_idx;
            }

            exp_desc->type_idx = CG_INTEGER_DEFAULT_TYPE;
            exp_desc->type     = Integer;
            exp_desc->linear_type = CG_INTEGER_DEFAULT_TYPE;
         }
         break;

      case CN_Tbl_Idx :
         type_idx		= CN_TYPE_IDX(IR_IDX_L(clen_idx));
         OPND_FLD((*opnd))	= TYP_FLD(type_idx);
         OPND_IDX((*opnd))	= TYP_IDX(type_idx);
         OPND_LINE_NUM((*opnd)) = line;
         OPND_COL_NUM((*opnd))  = col;
         exp_desc->constant	= TRUE;
         exp_desc->foldable	= TRUE;

         if (TYP_FLD(type_idx) == CN_Tbl_Idx) {
            exp_desc->type_idx = CN_TYPE_IDX(TYP_IDX(type_idx));
         }
         else {
            exp_desc->type_idx = ATD_TYPE_IDX(TYP_IDX(type_idx));
         }

         exp_desc->type = TYP_TYPE(exp_desc->type_idx);
         exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
         break;

      case IR_Tbl_Idx :

         ir_idx = IR_IDX_L(clen_idx);

         if ((IR_OPR(ir_idx) == Substring_Opr        ||
              IR_OPR(ir_idx) == Whole_Substring_Opr)  &&
             IL_FLD(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx)))) 
                                                             != NO_Tbl_Idx) {

            COPY_OPND((*opnd), IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(
                                    IR_IDX_R(ir_idx)))));

            if (OPND_FLD((*opnd)) == CN_Tbl_Idx) {
               exp_desc->type_idx = CN_TYPE_IDX(OPND_IDX((*opnd)));
               exp_desc->constant = TRUE;
               exp_desc->foldable = TRUE;
            }
            else if (OPND_FLD((*opnd)) == IR_Tbl_Idx) {
               exp_desc->type_idx = IR_TYPE_IDX(OPND_IDX((*opnd)));
            }
            else if (OPND_FLD((*opnd)) == AT_Tbl_Idx) {
               exp_desc->type_idx = ATD_TYPE_IDX(OPND_IDX((*opnd)));
            }

            exp_desc->type = TYP_TYPE(exp_desc->type_idx);
            exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
         }
         break;
   }

EXIT:

   TRACE (Func_Exit, "fold_clen_opr", NULL);

   return;

}  /* fold_clen_opr */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void set_shape_for_deferred_funcs(expr_arg_type         *exp_desc,
                                  int                    call_idx)

{
   int          	attr_idx;
   int          	bd_idx;
   int			ch_idx = NULL_IDX;
   int			col;
   int			dummy_idx;
   boolean		has_sf = FALSE;
   int			i;
   int			ir_idx;
   int			line;
   int          	list_idx;
   expr_arg_type	loc_exp_desc;
   int          	minus_idx;
   opnd_type    	opnd;
   int          	plus_idx;
   int			pgm_idx;
   cif_usage_code_type  save_xref_state;
   int			sn_idx;


   TRACE (Func_Entry, "set_shape_for_deferred_funcs", NULL);

   pgm_idx = IR_IDX_L(call_idx);
   attr_idx = ATP_RSLT_IDX(IR_IDX_L(call_idx));
   bd_idx = ATD_ARRAY_IDX(attr_idx);

   if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
      ch_idx = ATD_TYPE_IDX(attr_idx);
   }

   if ((bd_idx && BD_ARRAY_SIZE(bd_idx) == Var_Len_Array)  ||
       (ch_idx && TYP_FLD(ch_idx) == AT_Tbl_Idx)) {

      has_sf = TRUE;

      /* set up the dummy args as stmt func dargs */

      list_idx = IR_IDX_R(call_idx);
      sn_idx = ATP_FIRST_IDX(pgm_idx);

      if (ATP_EXTRA_DARG(pgm_idx)) {
         sn_idx++;
      }

      for (i = 0; i < IR_LIST_CNT_R(call_idx); i++) {
         dummy_idx = SN_ATTR_IDX(sn_idx);

         ATD_SF_DARG(dummy_idx) = TRUE;

         ATD_SF_LINK(dummy_idx) = IL_ARG_DESC_IDX(list_idx);
         COPY_OPND(opnd, IL_OPND(list_idx));

         if (arg_info_list[ATD_SF_LINK(dummy_idx)].ed.reference &&
             OPND_FLD(opnd) == IR_Tbl_Idx)                      {

            if (IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr) {
               COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
            }

            if (OPND_FLD(opnd) == IR_Tbl_Idx &&
                IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) {

               COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
            }

           /* whole subscript and substring need to be removed       */
           /* since we don't know how these args will be referenced. */
           /* I don't think dv_deref_oprs need to be removed.        */
         }

         ATD_FLD(dummy_idx)        = OPND_FLD(opnd);
         ATD_SF_ARG_IDX(dummy_idx) = OPND_IDX(opnd);

         sn_idx++;
         list_idx = IL_NEXT_LIST_IDX(list_idx);
      }
   }

   line = IR_LINE_NUM(call_idx);
   col  = IR_COL_NUM(call_idx);

   if (ch_idx) {
      /* fill in exp_desc->char_len */

      if (TYP_CHAR_CLASS(ch_idx) == Const_Len_Char) {
         exp_desc->char_len.fld = TYP_FLD(ch_idx);
         exp_desc->char_len.idx = TYP_IDX(ch_idx);
      }
      else if (TYP_FLD(ch_idx) == AT_Tbl_Idx) {

         if (TYP_CHAR_CLASS(ch_idx) == Assumed_Size_Char) {
            /* TYP_ORIG_LEN_IDX not set for Assumed_Size_Char */
            COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(TYP_IDX(ch_idx))));
         }
         else {
            COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(TYP_ORIG_LEN_IDX(ch_idx))));
         }

         copy_subtree(&opnd, &opnd, 0, 0);

         loc_exp_desc.rank = 0;
         save_xref_state   = xref_state;
         xref_state        = CIF_No_Usage_Rec;
         expr_semantics(&opnd, &loc_exp_desc);
         xref_state        = save_xref_state;

         COPY_OPND((exp_desc->char_len), opnd);
      }
   }

   if (bd_idx) {

      switch (BD_ARRAY_CLASS(bd_idx)) {

         case Explicit_Shape :

            if (BD_ARRAY_SIZE(bd_idx) == Constant_Size)   {
               get_shape_from_attr(exp_desc, 
                                   attr_idx,
                                   exp_desc->rank,
                                   IR_LINE_NUM(call_idx),
                                   IR_COL_NUM(call_idx));
            }
            else if (BD_ARRAY_SIZE(bd_idx) == Var_Len_Array) {

               /* set up extent expression for each dim */

               for (i = 0; i < BD_RANK(bd_idx); i++) {

                  NTR_IR_TBL(plus_idx);
                  IR_OPR(plus_idx) = Plus_Opr;
                  IR_TYPE_IDX(plus_idx)   = CG_INTEGER_DEFAULT_TYPE;
                  IR_LINE_NUM(plus_idx) = line;
                  IR_COL_NUM(plus_idx) = col;

                  IR_FLD_R(plus_idx) = CN_Tbl_Idx;
                  IR_IDX_R(plus_idx) = CN_INTEGER_ONE_IDX;
                  IR_LINE_NUM_R(plus_idx) = line;
                  IR_COL_NUM_R(plus_idx) = col;

                  NTR_IR_TBL(minus_idx);
                  IR_OPR(minus_idx) = Minus_Opr;
                  IR_TYPE_IDX(minus_idx)   = CG_INTEGER_DEFAULT_TYPE;
                  IR_LINE_NUM(minus_idx) = line;
                  IR_COL_NUM(minus_idx) = col;

                  IR_FLD_L(plus_idx) = IR_Tbl_Idx;
                  IR_IDX_L(plus_idx) = minus_idx;

                  if (BD_LB_FLD(bd_idx,i+1) == AT_Tbl_Idx) {
                     COPY_OPND(IR_OPND_R(minus_idx), 
                               IR_OPND_R(ATD_TMP_IDX(BD_LB_IDX(bd_idx,i+1))));
                  }
                  else {
                     IR_FLD_R(minus_idx) = BD_LB_FLD(bd_idx, i+1);
                     IR_IDX_R(minus_idx) = BD_LB_IDX(bd_idx, i+1);
                     IR_LINE_NUM_R(minus_idx) = line;
                     IR_COL_NUM_R(minus_idx) = col;
                  }

                  COPY_OPND(opnd, IR_OPND_R(minus_idx));
                  copy_subtree(&opnd, &opnd, 0, 0);
                  COPY_OPND(IR_OPND_R(minus_idx), opnd);

                  if (BD_UB_FLD(bd_idx,i+1) == AT_Tbl_Idx) {
                     COPY_OPND(IR_OPND_L(minus_idx), 
                               IR_OPND_R(ATD_TMP_IDX(BD_UB_IDX(bd_idx,i+1))));
                  }
                  else {
                     IR_FLD_L(minus_idx) = BD_UB_FLD(bd_idx, i+1);
                     IR_IDX_L(minus_idx) = BD_UB_IDX(bd_idx, i+1);
                     IR_LINE_NUM_L(minus_idx) = line;
                     IR_COL_NUM_L(minus_idx) = col;
                  }

                  COPY_OPND(opnd, IR_OPND_L(minus_idx));
                  copy_subtree(&opnd, &opnd, 0, 0);
                  COPY_OPND(IR_OPND_L(minus_idx), opnd);

                  OPND_FLD(opnd) = IR_Tbl_Idx;
                  OPND_IDX(opnd) = plus_idx;

                  loc_exp_desc.rank = 0;
                  save_xref_state   = xref_state;
                  xref_state        = CIF_No_Usage_Rec;
                  expr_semantics(&opnd, &loc_exp_desc);
                  xref_state        = save_xref_state;

                  COPY_OPND((exp_desc->shape[i]), opnd);
                  SHAPE_FOLDABLE(exp_desc->shape[i]) = loc_exp_desc.foldable;
                  SHAPE_WILL_FOLD_LATER(exp_desc->shape[i]) = 
                                               loc_exp_desc.will_fold_later;
               }
            }
            break;

         case Assumed_Size   :
            /* don't know what to do here */
            /* probable shouldn't get here */
            PRINTMSG(IR_LINE_NUM(call_idx), 968, Internal,
                     IR_COL_NUM(call_idx));

            break;

         case Deferred_Shape :
         case Assumed_Shape  :

            /* these are dope vectors */

            for (i = 0; i < BD_RANK(bd_idx); i++) {

               NTR_IR_TBL(ir_idx);
               IR_OPR(ir_idx) = Dv_Access_Extent;
               IR_TYPE_IDX(ir_idx)   = SA_INTEGER_DEFAULT_TYPE;
               IR_DV_DIM(ir_idx) = i + 1;

               IR_FLD_L(ir_idx) = AT_Tbl_Idx;
               IR_IDX_L(ir_idx) = attr_idx;

               IR_LINE_NUM(ir_idx) = IR_LINE_NUM(call_idx);
               IR_COL_NUM(ir_idx) = IR_COL_NUM(call_idx);
               IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(call_idx);
               IR_COL_NUM_L(ir_idx) = IR_COL_NUM(call_idx);

               exp_desc->shape[i].fld = IR_Tbl_Idx;
               exp_desc->shape[i].idx = ir_idx;
               SHAPE_FOLDABLE(exp_desc->shape[i]) = FALSE;
               SHAPE_WILL_FOLD_LATER(exp_desc->shape[i]) = FALSE;
            }
            break;

   
      }
   }

   if (has_sf) {
      sn_idx = ATP_FIRST_IDX(pgm_idx);

      if (ATP_EXTRA_DARG(pgm_idx)) {
         sn_idx++;
      }

      for (i = 0; i < IR_LIST_CNT_R(call_idx); i++) {
         ATD_SF_DARG(SN_ATTR_IDX(sn_idx)) = FALSE;
         sn_idx++;
      }
   }


   TRACE (Func_Exit, "set_shape_for_deferred_funcs", NULL);

   return;

}  /* set_shape_for_deferred_funcs */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Create an internal dope vector for use in folding array intrinsics.   *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      dope_vec - address of internal dope vector to fill in.                *|
|*      r_opnd   - address of opnd pointing to "target".                      *|
|*      just_init- TRUE => just initialize header.                            *|
|*      exp_desc - address of the expression descriptor of target.            *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

boolean	gen_internal_dope_vector(int_dope_type		*dope_vec,
				 opnd_type		*r_opnd,
				 boolean		 just_init,
				 expr_arg_type		*exp_desc)

{
#ifdef KEY /* Bug 10177 */
   int			bd_idx = 0;
   int			cn_idx = 0;
#else /* KEY Bug 10177 */
   int			bd_idx;
   int			cn_idx;
#endif /* KEY Bug 10177 */
   int			column;
   long_type         	constant[2];
   int          	i;
# if defined(_HOST_OS_UNICOS) && defined(_TARGET_OS_UNICOS)
   _fcd                 fcd_r;
# endif
   int			line;
   boolean		ok		= TRUE;
   opnd_type		opnd;
   int          	type_idx;


   TRACE (Func_Entry, "gen_internal_dope_vector", NULL);

   type_idx = exp_desc->type_idx;

   /*********************************************\
   |* see if we need to assign r_opnd to a tmp. *|
   \*********************************************/

   if (just_init) {
      /* intentionally blank */
   }
   else if (OPND_FLD((*r_opnd)) == CN_Tbl_Idx) {
      cn_idx = OPND_IDX((*r_opnd));
   }
   else if ((exp_desc->reference  ||
             exp_desc->tmp_reference) &&
            ! exp_desc->section)      {

      COPY_OPND(opnd, (*r_opnd));

      while (OPND_FLD(opnd) == IR_Tbl_Idx) {
         COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
      }

      if (ATD_FLD(OPND_IDX(opnd)) == IR_Tbl_Idx) {
         COPY_OPND(opnd, (*r_opnd));

         if (fold_aggragate_expression(&opnd, exp_desc, TRUE)) {
            cn_idx = OPND_IDX(opnd);

            if (exp_desc->rank) {
               bd_idx = create_bd_ntry_for_const(exp_desc,
                                                 stmt_start_line,
                                                 stmt_start_col);
            }
         }
         else {
            ok = FALSE;
            goto EXIT;
         }
      }
      else {
         if (ATD_CLASS(OPND_IDX(opnd)) == Constant) {
            cn_idx = ATD_CONST_IDX(OPND_IDX(opnd));
         }
         else {
            cn_idx = ATD_TMP_IDX(OPND_IDX(opnd));
         }

         bd_idx = ATD_ARRAY_IDX(OPND_IDX(opnd));
      }
   }
   else {
      COPY_OPND(opnd, (*r_opnd));

      if (fold_aggragate_expression(&opnd, exp_desc, TRUE)) {
         cn_idx = OPND_IDX(opnd);

         if (exp_desc->rank) {
            bd_idx = create_bd_ntry_for_const(exp_desc, 
                                              stmt_start_line,
                                              stmt_start_col);
         }
      }
      else {
         ok = FALSE;
         goto EXIT;
      }
   }

# ifdef _TARGET_OS_MAX  /* BRIANJ */
   if (! just_init &&
       TYP_LINEAR(CN_TYPE_IDX(cn_idx)) == Complex_4) {
      /* must pack it into one word (an Integer_8 constant) */

      constant[0] = CN_CONST(cn_idx) << 32;
      constant[0] |= (CP_CONSTANT(CN_POOL_IDX(cn_idx) + 1) & 0xFFFFFFFF);

      cn_idx = ntr_const_tbl(Integer_8,
                             FALSE,
                             constant);
   }
   else 
# endif
   if (! just_init &&
       exp_desc->rank == 0 &&
       exp_desc->type != Character &&
       exp_desc->type != Structure &&
       storage_bit_size_tbl[TYP_LINEAR(CN_TYPE_IDX(cn_idx))] <
                     TARGET_BITS_PER_WORD) {

#if !defined(_HOST_LITTLE_ENDIAN)
      /* must shift the constant so that it is left justified */
      /* word size integer (CG_INTEGER_DEFAULT_TYPE)          */

      constant[0] = CN_CONST(cn_idx) << (TARGET_BITS_PER_WORD -
                       storage_bit_size_tbl[TYP_LINEAR(CN_TYPE_IDX(cn_idx))]);

      cn_idx = ntr_const_tbl(CG_INTEGER_DEFAULT_TYPE,
                             FALSE,
                            constant);
#endif
   }

   /*************\
   |* BASE ADDR *|
   \*************/

   if (just_init) {
      dope_vec->base_addr = 0;
   }
# if defined(_HOST_OS_UNICOS) && defined(_TARGET_OS_UNICOS)

    /* BRIANJ */

   else if (exp_desc->type == Character) {
      fcd_r = _cptofcd((char *)&CN_CONST(cn_idx),
                       CN_INT_TO_C(TYP_IDX(exp_desc->type_idx)));
      dope_vec->base_addr = *(int *)&fcd_r;
   }
   else if (exp_desc->type == Structure &&
            ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) {
      fcd_r = _cptofcd((char *)&CN_CONST(cn_idx),
     (CN_INT_TO_C(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(exp_desc->type_idx)))) >> 3);
      dope_vec->base_addr = *(int *)&fcd_r;
   }
# endif
   else {
      dope_vec->base_addr = (long)&CN_CONST(cn_idx);
   }

   /*************\
   |* EL_LEN    *|
   \*************/

   find_opnd_line_and_column(r_opnd, &line, &column);

   if (exp_desc->type == Structure) {

      cn_idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
      if (compare_cn_and_value(cn_idx,
                               MAX_DV_EL_LEN,
                               Ge_Opr)) {
         PRINTMSG(line, 1174, Error, column, CN_INT_TO_C(cn_idx),MAX_DV_EL_LEN);
         dope_vec->el_len = MAX_DV_EL_LEN;
      }
      else { /* BRIANJ */
         dope_vec->el_len = CN_INT_TO_C(cn_idx);
      }
   }
   else if (exp_desc->type == Character) {

      if (exp_desc->char_len.fld == CN_Tbl_Idx) {

         if (char_len_in_bytes) {

            if (compare_cn_and_value(exp_desc->char_len.idx,
                                     MAX_DV_EL_LEN,
                                     Ge_Opr)) {
               PRINTMSG(line, 1174, Error, column,
                        CN_INT_TO_C(exp_desc->char_len.idx),
                        MAX_DV_EL_LEN);
               dope_vec->el_len = MAX_DV_EL_LEN;
            }
            else {
               dope_vec->el_len = CN_INT_TO_C(exp_desc->char_len.idx);
            }
         }
         else {

            if (compare_cn_and_value(exp_desc->char_len.idx,
                                     MAX_DV_EL_LEN/8,
                                     Ge_Opr)) {
               PRINTMSG(line, 1174, Error, column,
                        CN_INT_TO_C(exp_desc->char_len.idx),
                        MAX_DV_EL_LEN/8);
               dope_vec->el_len = MAX_DV_EL_LEN;
            }
            else {
               dope_vec->el_len = CN_INT_TO_C(exp_desc->char_len.idx)*8;
            }
         }
      }
      else {
         PRINTMSG(line, 969, Internal, column);
      }
   }
   else {
      dope_vec->el_len = storage_bit_size_tbl[exp_desc->linear_type];
   }

   /*************\
   |* ASSOC     *|
   \*************/

   if (just_init) {
      dope_vec->assoc = 0;
   }
   else {
      dope_vec->assoc = 1;
   }

   /*************\
   |* PTR_ALLOC *|
   \*************/

   dope_vec->ptr_alloc = 0;

   /*************\
   |* P_OR_A    *|
   \*************/

   dope_vec->p_or_a = 1;		/* pointer */

   /*************\
   |* A_CONTIG  *|
   \*************/

   dope_vec->a_contig = 0;

   /*************\
   |* UNUSED 1  *|
   \*************/

   dope_vec->unused_1 = 0;

# if defined(_TARGET64) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
   /*************\
   |* UNUSED 2  *|
   \*************/

   dope_vec->unused_2 = 0;
# endif


   /*************\
   |* N_DIM     *|
   \*************/

   dope_vec->num_dims = exp_desc->rank;

# if defined(_TARGET64) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
# ifndef _TYPE_CODE_64_BIT
   /*************\
   |* UNUSED 3  *|
   \*************/

   dope_vec->unused_3 = 0;
# endif
# endif

   /*************\
   |* TYPE_CODE *|
   \*************/

   make_io_type_code(type_idx, constant);
# ifdef _TYPE_CODE_64_BIT
   dope_vec->type_code = *(f90_type_t *)constant;
# else
   dope_vec->type_code = *constant;
# endif

   /*************\
   |* ORIG_BASE *|
   \*************/

   dope_vec->orig_base = 0;

   /*************\
   |* ORIG_SIZE *|
   \*************/

#ifdef KEY /* Bug 6845 */
   /* If this dope vector could have allocatable components, we need to do
    * something here */
#endif /* KEY Bug 6845 */

   dope_vec->orig_size = 0;

   for (i = 0; i < exp_desc->rank; i++) {

      /*************\
      |* DIM i LB  *|
      \*************/

      if (just_init) {
         dope_vec->dim[i].low_bound = 0;
      }
      else {
         /* set to one */
         dope_vec->dim[i].low_bound = 1;
      }


      /*************\
      |* DIM i EX  *|
      \*************/

      if (just_init) {
         dope_vec->dim[i].extent = 0;
      }
      else if (compare_cn_and_value(BD_XT_IDX(bd_idx, i+1), 0, Lt_Opr)) {
         dope_vec->dim[i].extent = 0;
      }
      else { /* BRIANJ */
         dope_vec->dim[i].extent = CN_INT_TO_C(BD_XT_IDX(bd_idx, i+1));
      }

      /*************\
      |* DIM i SM  *|
      \*************/

      if (just_init) {
         dope_vec->dim[i].stride_mult = 0;
      }
      else { /* BRIANJ */
         dope_vec->dim[i].stride_mult = CN_INT_TO_C(BD_SM_IDX(bd_idx, i+1));
      }
   }

EXIT:

   TRACE (Func_Exit, "gen_internal_dope_vector", NULL);

   return(ok);

}  /* gen_internal_dope_vector */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Transform a reference of character sequence derived type to a         *|
|*      substring reference of the first component.                           *|
|*									      *|
|* Input parameters:							      *|
|*	top_opnd - address of top of tree.                                    *|
|*      type_idx - idx to type table.                                         *|
|*									      *|
|* Output parameters:							      *|
|*	top_opnd - address of top of new tree.                                *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void	transform_char_sequence_ref(opnd_type		*top_opnd,
				    int			 type_idx)

{
   int			col;
   int			ir_idx;
   size_offset_type	length;
   int			line;
   int			list_idx;
   size_offset_type	num_chars;
   opnd_type   		opnd;

# if 0
   int			attr_idx;
   int			bd_idx;
   int			i;
# endif

   TRACE (Func_Entry, "transform_char_sequence_ref", NULL);

   switch (OPND_FLD((*top_opnd))) {
      case AT_Tbl_Idx :

         if (TYP_TYPE(ATD_TYPE_IDX(OPND_IDX((*top_opnd)))) == Structure &&
             ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(OPND_IDX((*top_opnd)))))) {

            goto REFERENCE;
         }
         else {
            goto EXIT;
         }
     
      case IR_Tbl_Idx :

# ifdef _DEBUG
         if (IR_TYPE_IDX(OPND_IDX((*top_opnd))) == NULL_IDX) {
            print_ir(OPND_IDX((*top_opnd)));
            find_opnd_line_and_column(top_opnd, &line, &col);
            PRINTMSG(line, 993, Internal, col);
         }
# endif

         if ((IR_OPR(OPND_IDX((*top_opnd))) == Struct_Opr ||
              IR_OPR(OPND_IDX((*top_opnd))) == Dv_Deref_Opr ||
              IR_OPR(OPND_IDX((*top_opnd))) == Subscript_Opr ||
              IR_OPR(OPND_IDX((*top_opnd))) == Whole_Subscript_Opr ||
              IR_OPR(OPND_IDX((*top_opnd))) == Section_Subscript_Opr) &&
             TYP_TYPE(IR_TYPE_IDX(OPND_IDX((*top_opnd)))) == Structure &&
             ATT_CHAR_SEQ(TYP_IDX(IR_TYPE_IDX(OPND_IDX((*top_opnd)))))) {

            goto REFERENCE;
         }
         else if (TYP_TYPE(IR_TYPE_IDX(OPND_IDX((*top_opnd)))) != Structure ||
                  ! ATT_CHAR_SEQ(TYP_IDX(IR_TYPE_IDX(OPND_IDX((*top_opnd)))))) {

            COPY_OPND(opnd, IR_OPND_L(OPND_IDX((*top_opnd))));
            transform_char_sequence_ref(&opnd, type_idx);
            COPY_OPND(IR_OPND_L(OPND_IDX((*top_opnd))), opnd);

            COPY_OPND(opnd, IR_OPND_R(OPND_IDX((*top_opnd))));
            transform_char_sequence_ref(&opnd, type_idx);
            COPY_OPND(IR_OPND_R(OPND_IDX((*top_opnd))), opnd);

            goto EXIT;
         }
         else {
            COPY_OPND(opnd, IR_OPND_L(OPND_IDX((*top_opnd))));
            transform_char_sequence_ref(&opnd, type_idx);
            COPY_OPND(IR_OPND_L(OPND_IDX((*top_opnd))), opnd);

            COPY_OPND(opnd, IR_OPND_R(OPND_IDX((*top_opnd))));
            transform_char_sequence_ref(&opnd, type_idx);
            COPY_OPND(IR_OPND_R(OPND_IDX((*top_opnd))), opnd);

            find_opnd_line_and_column(top_opnd, &line, &col);

            CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);

            TYP_TYPE(TYP_WORK_IDX)       = Character;
            TYP_LINEAR(TYP_WORK_IDX)     = CHARACTER_DEFAULT_TYPE;
            TYP_DESC(TYP_WORK_IDX)       = Default_Typed;
            TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char;
            TYP_FLD(TYP_WORK_IDX)        = CN_Tbl_Idx;

            num_chars.idx	= CN_INTEGER_CHAR_BIT_IDX;
            num_chars.fld	= CN_Tbl_Idx;

            length.fld		= ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
            length.idx		= ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));

            size_offset_binary_calc(&length, &num_chars, Div_Opr, &num_chars);

            if (num_chars.fld == NO_Tbl_Idx) {
               TYP_FLD(TYP_WORK_IDX)	= CN_Tbl_Idx;
               TYP_IDX(TYP_WORK_IDX)	= ntr_const_tbl(num_chars.type_idx, 
                                                        FALSE,
                                                        num_chars.constant);
            }
            else {
               TYP_FLD(TYP_WORK_IDX)	= num_chars.fld;
               TYP_IDX(TYP_WORK_IDX)	= num_chars.idx;
            }

            IR_TYPE_IDX(OPND_IDX((*top_opnd))) = ntr_type_tbl();
            goto EXIT;
         }

         /* break;  - Both sides of the IF end with GOTOs */

      case IL_Tbl_Idx :
         list_idx = OPND_IDX((*top_opnd));

         while (list_idx) {
            COPY_OPND(opnd, IL_OPND(list_idx));
            transform_char_sequence_ref(&opnd, type_idx);
            COPY_OPND(IL_OPND(list_idx), opnd);
        
            list_idx = IL_NEXT_LIST_IDX(list_idx);
         }
         goto EXIT;

      case CN_Tbl_Idx :
      case SH_Tbl_Idx :
      case NO_Tbl_Idx   :
         goto EXIT;
   }

REFERENCE:

   find_opnd_line_and_column(top_opnd, &line, &col);

   num_chars.idx	= CN_INTEGER_CHAR_BIT_IDX;
   num_chars.fld	= CN_Tbl_Idx;
   length.fld		= ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
   length.idx		= ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));

   size_offset_binary_calc(&length, &num_chars, Div_Opr, &num_chars);

# if 0
   while (TYP_TYPE(type_idx) == Structure) {

      attr_idx = SN_ATTR_IDX(ATT_FIRST_CPNT_IDX(TYP_IDX(type_idx)));

      NTR_IR_TBL(ir_idx);
      IR_OPR(ir_idx) = Struct_Opr;
      IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
      IR_LINE_NUM(ir_idx) = line;
      IR_COL_NUM(ir_idx) = col;  
      COPY_OPND(IR_OPND_L(ir_idx), (*top_opnd));
      OPND_FLD((*top_opnd)) = IR_Tbl_Idx;
      OPND_IDX((*top_opnd)) = ir_idx;

      IR_FLD_R(ir_idx) = AT_Tbl_Idx;
      IR_IDX_R(ir_idx) = attr_idx;
      IR_LINE_NUM_R(ir_idx) = line;
      IR_COL_NUM_R(ir_idx)  = col;

      if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
         bd_idx = ATD_ARRAY_IDX(attr_idx);

         NTR_IR_TBL(ir_idx);
         IR_OPR(ir_idx) = Subscript_Opr;
         IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
         IR_LINE_NUM(ir_idx) = line;
         IR_COL_NUM(ir_idx) = col;
         COPY_OPND(IR_OPND_L(ir_idx), (*top_opnd));
         OPND_FLD((*top_opnd)) = IR_Tbl_Idx;
         OPND_IDX((*top_opnd)) = ir_idx;

         NTR_IR_LIST_TBL(list_idx);
         IR_FLD_R(ir_idx) = IL_Tbl_Idx;
         IR_IDX_R(ir_idx) = list_idx;
         IR_LIST_CNT_R(ir_idx) = BD_RANK(bd_idx);

         IL_FLD(list_idx) = BD_LB_FLD(bd_idx, 1);
         IL_IDX(list_idx) = BD_LB_IDX(bd_idx, 1);
         IL_LINE_NUM(list_idx) = line;
         IL_COL_NUM(list_idx)  = col;

         if (IL_FLD(list_idx) == AT_Tbl_Idx) {
            ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx));
         }

         for (i = 2; i <= BD_RANK(bd_idx); i++) {

            NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
            IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
            list_idx = IL_NEXT_LIST_IDX(list_idx);

            IL_FLD(list_idx) = BD_LB_FLD(bd_idx, i);
            IL_IDX(list_idx) = BD_LB_IDX(bd_idx, i);
            IL_LINE_NUM(list_idx) = line;
            IL_COL_NUM(list_idx)  = col;

            if (IL_FLD(list_idx) == AT_Tbl_Idx) {
               ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx));
            }
         }
      }

      type_idx = ATD_TYPE_IDX(attr_idx);
   }
# endif

   NTR_IR_TBL(ir_idx);
   IR_OPR(ir_idx) = Substring_Opr;
   IR_TYPE_IDX(ir_idx) = CHARACTER_DEFAULT_TYPE;
   IR_LINE_NUM(ir_idx) = line;
   IR_COL_NUM(ir_idx) = col;

   COPY_OPND(IR_OPND_L(ir_idx), (*top_opnd));
   OPND_FLD((*top_opnd)) = IR_Tbl_Idx;
   OPND_IDX((*top_opnd)) = ir_idx;

   NTR_IR_LIST_TBL(list_idx);
   IR_FLD_R(ir_idx) = IL_Tbl_Idx;
   IR_IDX_R(ir_idx) = list_idx;
   IR_LIST_CNT_R(ir_idx) = 2;
   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   if (num_chars.fld == NO_Tbl_Idx) {
      IL_FLD(list_idx) = CN_Tbl_Idx;
      IL_IDX(list_idx) = ntr_const_tbl(num_chars.type_idx, 
                                       FALSE, 
                                       num_chars.constant);
   }
   else {
      IL_FLD(list_idx) = num_chars.fld;
      IL_IDX(list_idx) = num_chars.idx;
   }

   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   add_substring_length(ir_idx);

EXIT:

   TRACE (Func_Exit, "transform_char_sequence_ref", NULL);

   return;

}  /* "transform_char_sequence_ref" */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Because of the problems of deferred function expansion of variable    *|
|*      length character functions within concats, this routine creates a new *|
|*      length expression for the concat after the functions have been        *|
|*      processed. (Their length is a tmp at this point).                     *|
|*									      *|
|* Input parameters:							      *|
|*	concat_idx - IR_Tbl_Idx for concat.                                   *|
|*									      *|
|* Output parameters:							      *|
|*	len_opnd - the length expression tree.                                *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void get_concat_len(int		concat_idx,
                    opnd_type	*len_opnd)

{
   int			col;
   int			line;
   int			list_idx;
   opnd_type    	opnd;
   opnd_type    	opnd2;
   int			plus_idx;


   TRACE (Func_Entry, "get_concat_len", NULL);

   line = IR_LINE_NUM(concat_idx);
   col  = IR_COL_NUM(concat_idx);

   list_idx = IR_IDX_L(concat_idx);
   *len_opnd = null_opnd;

   while (list_idx) {

      COPY_OPND(opnd2, IL_OPND(list_idx));
      get_char_len(&opnd2, &opnd);

      if (OPND_FLD((*len_opnd)) == NO_Tbl_Idx) {
         COPY_OPND((*len_opnd), opnd);
      }
      else {
         NTR_IR_TBL(plus_idx);
         IR_OPR(plus_idx) = Plus_Opr;
         IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE;
         IR_LINE_NUM(plus_idx) = line;
         IR_COL_NUM(plus_idx) = col;

         COPY_OPND(IR_OPND_L(plus_idx), (*len_opnd));
         COPY_OPND(IR_OPND_R(plus_idx), opnd);
         OPND_FLD((*len_opnd)) = IR_Tbl_Idx;
         OPND_IDX((*len_opnd)) = plus_idx;
      }

      list_idx = IL_NEXT_LIST_IDX(list_idx);
   }

   TRACE (Func_Exit, "get_concat_len", NULL);

   return;

}  /* get_concat_len */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void get_char_len(opnd_type	*ref_opnd,
		  opnd_type	*length_opnd)

{
   int		cn_idx;
   int		ir_idx;
   int		line;
   int		col;
   opnd_type	opnd;

   TRACE (Func_Entry, "get_char_len", NULL);

   find_opnd_line_and_column(ref_opnd,
                             &line,
                             &col);

   switch(OPND_FLD((*ref_opnd))) {
      case IR_Tbl_Idx :
         ir_idx = OPND_IDX((*ref_opnd));

         if (IR_OPR(ir_idx) == Substring_Opr ||
             IR_OPR(ir_idx) == Whole_Substring_Opr) {

            COPY_OPND((*length_opnd), IL_OPND(IL_NEXT_LIST_IDX(
                        IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx)))));
         }
         else if (IR_OPR(ir_idx) == Stmt_Expansion_Opr ||
                  IR_OPR(ir_idx) == Paren_Opr) {
            COPY_OPND(opnd, IR_OPND_L(ir_idx));
            get_char_len(&opnd, length_opnd);
         }
         else if (IR_TYPE_IDX(ir_idx) != NULL_IDX &&
                  TYP_TYPE(IR_TYPE_IDX(ir_idx)) == Character) {

            OPND_FLD((*length_opnd)) = TYP_FLD(IR_TYPE_IDX(ir_idx));
            OPND_IDX((*length_opnd)) = TYP_IDX(IR_TYPE_IDX(ir_idx));
            OPND_LINE_NUM((*length_opnd)) = line;
            OPND_COL_NUM((*length_opnd))  = col;

            if (OPND_FLD((*length_opnd)) == AT_Tbl_Idx) {
               ADD_TMP_TO_SHARED_LIST(OPND_IDX((*length_opnd)));
            }
         }
         else {
            PRINTMSG(line, 626, Internal, col,
                     "type idx", "get_char_len");
         }
         break;

      case CN_Tbl_Idx :

         cn_idx = OPND_IDX((*ref_opnd));
# ifdef _DEBUG
         if (TYP_TYPE(CN_TYPE_IDX(cn_idx)) != Character) {
            PRINTMSG(line, 626, Internal, col,
                     "CHARACTER type constant"
                     "get_concat_len");
         }
# endif

         OPND_FLD((*length_opnd)) = TYP_FLD(CN_TYPE_IDX(cn_idx));
         OPND_IDX((*length_opnd)) = TYP_IDX(CN_TYPE_IDX(cn_idx));
         OPND_LINE_NUM((*length_opnd)) = line;
         OPND_COL_NUM((*length_opnd))  = col;
         break;

      default :
         PRINTMSG(line, 626, Internal, col,
                  "IR_Tbl_Idx or CN_Tbl_Idx",
                  "get_char_len");
         break;
   }


   TRACE (Func_Exit, "get_char_len", NULL);

   return;

}  /* get_char_len */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Gen the dv_whole_def_opr for variable size function processing.       *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      attr idx of tmp_dope_vector                                           *|
|*                                                                            *|
\******************************************************************************/

int gen_sf_dv_whole_def(opnd_type         *r_opnd,
                        int		   type_idx,
			int		   bd_idx)

{
   int          	asg_idx;
   opnd_type    	base_opnd;
   int          	col;
   long_type    	constant;
   int          	dope_idx	= NULL_IDX;
   int          	dv_attr_idx;
   int          	i;
   int          	ir_idx;
   int          	line;
   int          	list_idx;
   int          	loc_idx;
   int          	mult_idx;
   size_offset_type	num_chars;
   opnd_type    	opnd;
   long	    		rank;
   int          	rank_idx	= NULL_IDX;
   size_offset_type	result;


   TRACE (Func_Entry, "gen_sf_dv_whole_def", NULL);

   find_opnd_line_and_column(r_opnd, &line, &col);

   dv_attr_idx = gen_compiler_tmp(line, col, Priv, TRUE);

   ATD_TYPE_IDX(dv_attr_idx) = type_idx;
   ATD_STOR_BLK_IDX(dv_attr_idx)  = SCP_SB_STACK_IDX(curr_scp_idx);
   AT_SEMANTICS_DONE(dv_attr_idx) = TRUE;

   /* Positions 1-7 are deferred shape entries in bd table. */
   ATD_ARRAY_IDX(dv_attr_idx) = BD_RANK(bd_idx);

   ATD_IM_A_DOPE(dv_attr_idx)    = TRUE;

   NTR_IR_TBL(asg_idx);
   IR_OPR(asg_idx) = Dv_Def_Asg_Opr;
   IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(asg_idx) = line;
   IR_COL_NUM(asg_idx)  = col;

   NTR_IR_TBL(ir_idx);
   IR_OPR(ir_idx) = Dv_Whole_Def_Opr;
   IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(ir_idx) = line;
   IR_COL_NUM(ir_idx)  = col;

   IR_FLD_L(asg_idx) = AT_Tbl_Idx;
   IR_IDX_L(asg_idx) = dv_attr_idx;
   IR_LINE_NUM_L(asg_idx) = line;
   IR_COL_NUM_L(asg_idx)  = col;

   IR_FLD_R(asg_idx) = IR_Tbl_Idx;
   IR_IDX_R(asg_idx) = ir_idx;

   NTR_IR_LIST_TBL(list_idx);
   IR_FLD_L(ir_idx) = IL_Tbl_Idx;
   IR_IDX_L(ir_idx) = list_idx;

   rank = (long) BD_RANK(bd_idx);

   IR_LIST_CNT_L(ir_idx) = 10 + (3 * rank);
   IR_DV_DIM(ir_idx) = rank;

   /*************\
   |* BASE ADDR *|
   \*************/

   if (OPND_FLD((*r_opnd)) == AT_Tbl_Idx &&
       AT_OBJ_CLASS(OPND_IDX((*r_opnd))) == Data_Obj &&
       ATD_CLASS(OPND_IDX((*r_opnd))) == Compiler_Tmp &&
       (TYP_TYPE(ATD_TYPE_IDX(OPND_IDX((*r_opnd)))) == CRI_Ptr ||
        TYP_TYPE(ATD_TYPE_IDX(OPND_IDX((*r_opnd)))) == CRI_Ch_Ptr ||
        ATD_IM_A_DOPE(OPND_IDX((*r_opnd))))) {

      if (ATD_IM_A_DOPE(OPND_IDX((*r_opnd)))) {

         NTR_IR_TBL(loc_idx);
         IR_OPR(loc_idx) = Dv_Access_Base_Addr;
         IR_TYPE_IDX(loc_idx) = SA_INTEGER_DEFAULT_TYPE;
         IR_LINE_NUM(loc_idx) = line;
         IR_COL_NUM(loc_idx) = col;
         COPY_OPND(IR_OPND_L(loc_idx), (*r_opnd));
         IL_FLD(list_idx) = IR_Tbl_Idx;
         IL_IDX(list_idx) = loc_idx;
      }
      else {
         COPY_OPND(IL_OPND(list_idx), (*r_opnd));
      }
   }
   else {
      NTR_IR_TBL(loc_idx);
      IR_OPR(loc_idx)  = Loc_Opr;
      IR_LINE_NUM(loc_idx) = line;
      IR_COL_NUM(loc_idx)  = col;

      if (TYP_TYPE(type_idx) == Character) {
         IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
      }
      else {
         IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
      }

      IL_FLD(list_idx) = IR_Tbl_Idx;
      IL_IDX(list_idx) = loc_idx;

      make_base_subtree(r_opnd, &base_opnd, &rank_idx, &dope_idx);
      COPY_OPND(IR_OPND_L(loc_idx), base_opnd);

# ifdef _TRANSFORM_CHAR_SEQUENCE
# ifdef _TARGET_OS_UNICOS
      if (TYP_TYPE(type_idx) == Structure &&
          ATT_CHAR_SEQ(TYP_IDX(type_idx))) {

         IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
         COPY_OPND(opnd, IR_OPND_L(loc_idx));
         transform_char_sequence_ref(&opnd, type_idx);
         COPY_OPND(IR_OPND_L(loc_idx), opnd);
      }
# endif
# endif
   }


   /*************\
   |* EL_LEN    *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   if (TYP_TYPE(type_idx) == Structure) {
      IL_FLD(list_idx)	= (fld_type) ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
      IL_IDX(list_idx)	= ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
      IL_LINE_NUM(list_idx)	= line;
      IL_COL_NUM(list_idx)	= col;
   }
   else if (TYP_TYPE(type_idx) == Character) {

      if (TYP_FLD(type_idx) == CN_Tbl_Idx) {

         if (char_len_in_bytes) {      /* Len is in bytes on solaris */

            IL_FLD(list_idx)	= CN_Tbl_Idx;
            IL_IDX(list_idx)	= TYP_IDX(type_idx);
         }
         else {
            result.idx		= CN_INTEGER_CHAR_BIT_IDX;
            result.fld		= CN_Tbl_Idx;

            num_chars.fld	= TYP_FLD(type_idx);
            num_chars.idx	= TYP_IDX(type_idx);

            size_offset_binary_calc(&num_chars, &result, Mult_Opr, &result);

            if (result.fld == NO_Tbl_Idx) {
               IL_FLD(list_idx)	= CN_Tbl_Idx;
               IL_IDX(list_idx)	= ntr_const_tbl(result.type_idx,
                                                FALSE,
                                                result.constant);
            }
            else {
               IL_FLD(list_idx)	= result.fld;
               IL_IDX(list_idx)	= result.idx;
            }
         }
         IL_LINE_NUM(list_idx) = line;
         IL_COL_NUM(list_idx)  = col;
      }
      else {
         if (char_len_in_bytes) {
            /* Len is in bytes on solaris */
            IL_FLD(list_idx)      = TYP_FLD(type_idx);
            IL_IDX(list_idx)      = TYP_IDX(type_idx);
            IL_LINE_NUM(list_idx) = line;
            IL_COL_NUM(list_idx)  = col;

            if (IL_FLD(list_idx) == AT_Tbl_Idx) {
               ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx));
            }
         }
         else {

            NTR_IR_TBL(mult_idx);
            IR_OPR(mult_idx) = Mult_Opr;
            IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
            IR_LINE_NUM(mult_idx) = line;
            IR_COL_NUM(mult_idx)  = col;
            constant              = 8;
            IR_FLD_L(mult_idx)    = CN_Tbl_Idx;
            IR_IDX_L(mult_idx)    = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8);
            IR_LINE_NUM_L(mult_idx) = line;
            IR_COL_NUM_L(mult_idx)  = col;
   
            IR_FLD_R(mult_idx)    = TYP_FLD(type_idx);
            IR_IDX_R(mult_idx)    = TYP_IDX(type_idx);
            IR_LINE_NUM_R(mult_idx) = line;
            IR_COL_NUM_R(mult_idx)  = col;

            if (IR_FLD_R(mult_idx) == AT_Tbl_Idx) {
               ADD_TMP_TO_SHARED_LIST(IR_IDX_R(mult_idx));
            }

            IL_FLD(list_idx)      = IR_Tbl_Idx;
            IL_IDX(list_idx)      = mult_idx;
         }
      }
   }
   else {
      constant = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
      IL_FLD(list_idx) = CN_Tbl_Idx;
      IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, constant);
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;
   }

   /*************\
   |* ASSOC     *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   /*************\
   |* PTR_ALLOC *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;


   /*************\
   |* P_OR_A    *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;


   /*************\
   |* A_CONTIG  *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   /*************\
   |* N_DIM     *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, rank);
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;


   /*************\
   |* TYPE_CODE *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = create_dv_type_code(dv_attr_idx);
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   /*************\
   |* ORIG_BASE *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;


   /*************\
   |* ORIG_SIZE *|
   \*************/

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

#ifdef KEY /* Bug 6845 */
   /* If this dope vector could have allocatable components, the following
    * code needs to change */
   list_idx = do_alloc_cpnt(line, col, list_idx, 0);
#endif /* KEY Bug 6845 */

   for (i = 1; i <= rank; i++) {

      /*************\
      |* DIM i LB  *|
      \*************/

      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
      list_idx = IL_NEXT_LIST_IDX(list_idx);

      IL_FLD(list_idx) = BD_LB_FLD(bd_idx, i);
      IL_IDX(list_idx) = BD_LB_IDX(bd_idx, i);
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;

      if (IL_FLD(list_idx) == AT_Tbl_Idx) {
         ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx));
      }

      /*************\
      |* DIM i EX  *|
      \*************/

      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
      list_idx = IL_NEXT_LIST_IDX(list_idx);

      IL_FLD(list_idx) = BD_XT_FLD(bd_idx, i);
      IL_IDX(list_idx) = BD_XT_IDX(bd_idx, i);
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;

      if (IL_FLD(list_idx) == AT_Tbl_Idx) {
         ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx));
      }

      /*************\
      |* DIM i SM  *|
      \*************/

      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
      list_idx = IL_NEXT_LIST_IDX(list_idx);

      IL_FLD(list_idx) = BD_SM_FLD(bd_idx, i);
      IL_IDX(list_idx) = BD_SM_IDX(bd_idx, i);
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;

      if (IL_FLD(list_idx) == AT_Tbl_Idx) {
         ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx));
      }
   }

   gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);

   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   TRACE (Func_Exit, "gen_sf_dv_whole_def", NULL);

   return(dv_attr_idx);

}  /* gen_sf_dv_whole_def */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This routine determines the correct character length of an expression *|
|*      for use by the dope vector gen routines. This is necessary, since we  *|
|*      don't create new type entries for each node of a concat and substring *|
|*      tree. Remember the rule, don't use type_idx for character length for  *|
|*      a general case character expression. It must be calculated.           *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

static void compute_char_element_len(opnd_type		*char_len,
				     opnd_type		*char_opnd,
				     opnd_type		*result_opnd)

{
   int			col;
   int			line;
   expr_arg_type	loc_exp_desc;
   int			mult_idx;
   cif_usage_code_type  save_xref_state;


   TRACE (Func_Entry, "compute_char_element_len", NULL);

   find_opnd_line_and_column(char_opnd, &line, &col);

   if (OPND_FLD((*char_opnd))         == IR_Tbl_Idx &&
       IR_OPR(OPND_IDX((*char_opnd))) == Concat_Opr) {

      get_concat_len(OPND_IDX((*char_opnd)), result_opnd);
   }
   else {
      COPY_OPND((*result_opnd), (*char_len));
   }

   if (! char_len_in_bytes) {
      /* Len is in bytes for solaris */
      /* Len is in bits for everyone else */

      NTR_IR_TBL(mult_idx);
      IR_OPR(mult_idx) = Mult_Opr;
      IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
      IR_LINE_NUM(mult_idx) = line;
      IR_COL_NUM(mult_idx)  = col;
      IR_FLD_L(mult_idx)    = CN_Tbl_Idx;
      IR_IDX_L(mult_idx)    = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8);
      IR_LINE_NUM_L(mult_idx) = line;
      IR_COL_NUM_L(mult_idx)  = col;
   
      COPY_OPND(IR_OPND_R(mult_idx), (*result_opnd));
   
      OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
      OPND_IDX((*result_opnd)) = mult_idx;
   }

   /* try to fold it down */
   loc_exp_desc.rank = 0;
   save_xref_state = xref_state;
   xref_state      = CIF_No_Usage_Rec;
   expr_semantics(result_opnd, &loc_exp_desc);
   xref_state      = save_xref_state;

   TRACE (Func_Exit, "compute_char_element_len", NULL);

   return;

}  /* compute_char_element_len */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This routine determines the correct character length of an expression *|
|*      for use by the dope vector gen routines. This is necessary, since we  *|
|*      don't create new type entries for each node of a concat and substring *|
|*      tree. Remember the rule, don't use type_idx for character length for  *|
|*      a general case character expression. It must be calculated.           *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void get_shape_from_attr(expr_arg_type		*exp_desc,
		         int			 attr_idx,
		         int			 rank,
		         int			 line,
		         int			 column)

{
   int		i;
   int		ir_idx;


   TRACE (Func_Entry, "get_shape_from_attr", NULL);

   if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
      for (i = 0; i < rank; i++) {

         if (ATD_IM_A_DOPE(attr_idx)) {
            OPND_FLD(exp_desc->shape[i])	= IR_Tbl_Idx;
            NTR_IR_TBL(ir_idx);
            IR_OPR(ir_idx)			= Dv_Access_Extent;
            IR_TYPE_IDX(ir_idx)			= SA_INTEGER_DEFAULT_TYPE;
            IR_LINE_NUM(ir_idx)			= line;
            IR_COL_NUM(ir_idx)			= column;
            IR_DV_DIM(ir_idx)			= i + 1;
            IR_FLD_L(ir_idx)			= AT_Tbl_Idx;
            IR_IDX_L(ir_idx)			= attr_idx;
            IR_LINE_NUM_L(ir_idx)		= line;
            IR_COL_NUM_L(ir_idx)		= column;
            OPND_IDX(exp_desc->shape[i])	= ir_idx;

            SHAPE_FOLDABLE(exp_desc->shape[i])		= FALSE;
            SHAPE_WILL_FOLD_LATER(exp_desc->shape[i])	= FALSE;
         }
         else {
            OPND_FLD(exp_desc->shape[i]) = 
                        BD_XT_FLD(ATD_ARRAY_IDX(attr_idx), i+1);
            OPND_IDX(exp_desc->shape[i]) = 
                        BD_XT_IDX(ATD_ARRAY_IDX(attr_idx), i+1);
            OPND_LINE_NUM(exp_desc->shape[i])	= line;
            OPND_COL_NUM(exp_desc->shape[i])	= column;

            if (OPND_FLD(exp_desc->shape[i]) == AT_Tbl_Idx) {
               ADD_TMP_TO_SHARED_LIST(OPND_IDX(exp_desc->shape[i]));
            }

            if (OPND_FLD(exp_desc->shape[i]) == CN_Tbl_Idx) {
               SHAPE_FOLDABLE(exp_desc->shape[i])		= TRUE;
               SHAPE_WILL_FOLD_LATER(exp_desc->shape[i])	= TRUE;
            }
            else if (OPND_FLD(exp_desc->shape[i]) == AT_Tbl_Idx &&
                     AT_OBJ_CLASS(OPND_IDX(exp_desc->shape[i])) == Data_Obj &&
                     ATD_LCV_IS_CONST(OPND_IDX(exp_desc->shape[i]))) {
               SHAPE_FOLDABLE(exp_desc->shape[i])		= FALSE;
               SHAPE_WILL_FOLD_LATER(exp_desc->shape[i])	= TRUE;
            }
            else {
               SHAPE_FOLDABLE(exp_desc->shape[i])		= FALSE;
               SHAPE_WILL_FOLD_LATER(exp_desc->shape[i])	= FALSE;
            }
         }
      }
   }

   TRACE (Func_Exit, "get_shape_from_attr", NULL);

   return;

}  /* get_shape_from_attr */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This routine will generate a Init_Opr statement for compiler temps    *|
|*      and insert the statement before the end statement of the scope. It is *|
|*      used at pdgcs conversion time whenever a compiler temp is             *|
|*      encountered that has its ATD_TMP_INIT_NOT_DONE flag set. This is to   *|
|*      ensure that only the data init's of compiler temps (for constructors  *|
|*      and some folded intrinsics) are only added if the temp is still being *|
|*      referenced at interface time. No one else will optimize these out and *|
|*      they can make the binarys quite large and slow down loading.          *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void insert_init_stmt_for_tmp(int		tmp_idx)

{
   int		asg_idx;
   int		bd_idx;
   int		col;
   int		i;
   int		line;
   int		list_idx;
   int		save_curr_stmt_sh_idx;
   int		sub_idx;


   TRACE (Func_Entry, "insert_init_stmt_for_tmp", NULL);

   save_curr_stmt_sh_idx = curr_stmt_sh_idx;
   curr_stmt_sh_idx = SCP_LAST_SH_IDX(curr_scp_idx);

   line = AT_DEF_LINE(tmp_idx);
   col  = AT_DEF_COLUMN(tmp_idx);
   bd_idx = ATD_ARRAY_IDX(tmp_idx);

   NTR_IR_TBL(asg_idx);
   IR_OPR(asg_idx) = Init_Opr;
   IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
   IR_LINE_NUM(asg_idx) = line;
   IR_COL_NUM(asg_idx)  = col;
   IR_LINE_NUM_L(asg_idx) = line;
   IR_COL_NUM_L(asg_idx)  = col;

   if (ATD_FLD(tmp_idx) == IR_Tbl_Idx &&
       bd_idx != NULL_IDX) {

      NTR_IR_TBL(sub_idx);
      IR_OPR(sub_idx) = Subscript_Opr;
      IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(tmp_idx);
      IR_LINE_NUM(sub_idx) = line;
      IR_COL_NUM(sub_idx) = col;
      IR_FLD_L(sub_idx) = AT_Tbl_Idx;
      IR_IDX_L(sub_idx) = tmp_idx;
      IR_LINE_NUM_L(sub_idx) = line;
      IR_COL_NUM_L(sub_idx) = col;

      IR_FLD_L(asg_idx) = IR_Tbl_Idx;
      IR_IDX_L(asg_idx) = sub_idx;

      NTR_IR_LIST_TBL(list_idx);
      IR_FLD_R(sub_idx) = IL_Tbl_Idx;
      IR_LIST_CNT_R(sub_idx) = BD_RANK(bd_idx);
      IR_IDX_R(sub_idx) = list_idx;

      IL_FLD(list_idx) = BD_LB_FLD(bd_idx, 1);
      IL_IDX(list_idx) = BD_LB_IDX(bd_idx, 1);
      IL_LINE_NUM(list_idx) = line;
      IL_COL_NUM(list_idx)  = col;

      if (IL_FLD(list_idx) == AT_Tbl_Idx) {
         ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx));
      }

      for (i = 2; i <= BD_RANK(bd_idx); i++) {
         NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
         IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
         list_idx = IL_NEXT_LIST_IDX(list_idx);

         IL_FLD(list_idx) = BD_LB_FLD(bd_idx, i);
         IL_IDX(list_idx) = BD_LB_IDX(bd_idx, i);
         IL_LINE_NUM(list_idx) = line;
         IL_COL_NUM(list_idx)  = col;

         if (IL_FLD(list_idx) == AT_Tbl_Idx) {
            ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx));
         }
      }
   }
   else {
      IR_FLD_L(asg_idx)    = AT_Tbl_Idx;
      IR_IDX_L(asg_idx)    = tmp_idx;
   }

   NTR_IR_LIST_TBL(list_idx);
   IR_FLD_R(asg_idx) = IL_Tbl_Idx;
   IR_IDX_R(asg_idx) = list_idx;
   IR_LIST_CNT_R(asg_idx) = 3;

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = (ATD_FLD(tmp_idx) == CN_Tbl_Idx ? ATD_TMP_IDX(tmp_idx) :
                                      IR_IDX_R(ATD_TMP_IDX(tmp_idx)));
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = (ATD_FLD(tmp_idx) == CN_Tbl_Idx ? CN_INTEGER_ONE_IDX :
                               IR_IDX_L(ATD_TMP_IDX(tmp_idx)));
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;

   if (ATD_FLD(tmp_idx) == CN_Tbl_Idx) {
      IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
   }
   else {
      IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 
                                  storage_bit_size_tbl[TYP_LINEAR(CN_TYPE_IDX(
                                             IR_IDX_R(ATD_TMP_IDX(tmp_idx))))]);
   }

   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   gen_sh(Before, Assignment_Stmt, line, col,
          FALSE, FALSE, TRUE);
   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   curr_stmt_sh_idx = save_curr_stmt_sh_idx;

   ATD_TMP_INIT_NOT_DONE(tmp_idx) = FALSE;

   TRACE (Func_Exit, "insert_init_stmt_for_tmp", NULL);

   return;

}  /* insert_init_stmt_for_tmp */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	generate a static integer array of the specified size.                *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

int gen_static_integer_array_tmp(int	size,
				 int	line,
				 int	col)

{
   expr_arg_type	exp_desc;
   int			tmp_idx;
   int			type_idx;


   TRACE (Func_Entry, "gen_static_integer_array_tmp", NULL);

# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
   type_idx = SA_INTEGER_DEFAULT_TYPE;
# else
   type_idx = CG_INTEGER_DEFAULT_TYPE;
# endif

   tmp_idx                   = gen_compiler_tmp(line,col, Shared, TRUE);
   ATD_TYPE_IDX(tmp_idx)     = type_idx;
   ATD_SAVED(tmp_idx)        = TRUE;
   ATD_DATA_INIT(tmp_idx)    = TRUE;
   ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx);
   AT_SEMANTICS_DONE(tmp_idx)= TRUE;

   exp_desc = init_exp_desc;
   exp_desc.type                = Integer;
   exp_desc.type_idx            = type_idx;
   exp_desc.linear_type         = TYP_LINEAR(type_idx);
   exp_desc.rank                = 1;
   exp_desc.shape[0].fld        = CN_Tbl_Idx;
   exp_desc.shape[0].idx	= C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, size);

   ATD_ARRAY_IDX(tmp_idx) = create_bd_ntry_for_const(&exp_desc,
                                                     line,
                                                     col);


   TRACE (Func_Exit, "gen_static_integer_array_tmp", NULL);

   return(tmp_idx);

}  /* gen_static_integer_array_tmp */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

int cast_typeless_constant(int		cn_idx,
			   int		type_idx,
			   int		line,
			   int		col)

{
# if defined(_TARGET_OS_UNICOS)
   long_type	another_constant[MAX_WORDS_FOR_NUMERIC];
# endif

   char	       *char_ptr;
   long64	i;
   long64	k;
   int		l;
   int		new_const_idx;
   long64	new_word_size;
   long64	old_word_size;
   boolean	right_justified;
   long_type	the_constant[MAX_WORDS_FOR_NUMERIC];
   boolean	zero_pad;


   TRACE (Func_Entry, "cast_typeless_constant", NULL);

   if (TYP_TYPE(type_idx) == CRI_Ptr ||
       TYP_TYPE(type_idx) == CRI_Parcel_Ptr ||
       TYP_TYPE(type_idx) == CRI_Ch_Ptr) {
      type_idx = TYPELESS_DEFAULT_TYPE;
   }

   if (CN_HOLLERITH_TYPE(cn_idx) == H_Hollerith) {
      right_justified = FALSE;
      zero_pad = FALSE;
      old_word_size = TARGET_BITS_TO_WORDS(TYP_BIT_LEN(CN_TYPE_IDX(cn_idx)));
   }
   else if (CN_HOLLERITH_TYPE(cn_idx) == L_Hollerith) {
      right_justified = FALSE;
      zero_pad = TRUE;
      old_word_size = TARGET_BITS_TO_WORDS(TYP_BIT_LEN(CN_TYPE_IDX(cn_idx)));
   }
   else if (CN_HOLLERITH_TYPE(cn_idx) == R_Hollerith) {
      right_justified = TRUE;
      zero_pad = TRUE;
      old_word_size = TARGET_BITS_TO_WORDS(TYP_BIT_LEN(CN_TYPE_IDX(cn_idx)));
   }
   else if (TYP_TYPE(CN_TYPE_IDX(cn_idx)) == Character) {
      right_justified = FALSE;
      zero_pad = FALSE;
      old_word_size = TARGET_BYTES_TO_WORDS(
                         CN_INT_TO_C(TYP_IDX(CN_TYPE_IDX(cn_idx))));
   }
   else {
      /* non hollerith, non character, => typeless */
      right_justified = TRUE;
      zero_pad = TRUE;
      old_word_size = TARGET_BITS_TO_WORDS(TYP_BIT_LEN(CN_TYPE_IDX(cn_idx)));
   }


   if (TYP_TYPE(type_idx) == Typeless) {
      new_word_size = TARGET_BITS_TO_WORDS(TYP_BIT_LEN(type_idx));
   }
   else {
      new_word_size = TARGET_BITS_TO_WORDS(
                        storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
   }

   if (right_justified) {  /* BRIANJ */
      k = old_word_size - 1;
      for (i = new_word_size - 1; i >= 0; i--) {
         if (k < 0) {
            break;
         }
#if defined(TARG_X8664) || defined(TARG_MIPS)
         the_constant[new_word_size-1-i] = CP_CONSTANT(CN_POOL_IDX(cn_idx) + k);
#else
         the_constant[i] = CP_CONSTANT(CN_POOL_IDX(cn_idx) + k);
#endif
         k--;
      }

      while (i >= 0) {
         /* fill in pad */
         if (zero_pad) {
#if defined(TARG_X8664) || defined(TARG_MIPS)
// Bug 1819 (also 10769 for MIPS)
            the_constant[new_word_size-1-i] = 0;
#else
            the_constant[i] = 0;
#endif
         }
         else {
            char_ptr = (char *)&(the_constant[i]);
            for (l = 0; l < TARGET_CHARS_PER_WORD; l++) {
               char_ptr[l] = ' ';
            }
         }

         i--;
      }

      if (k >= 0) {
         /* issue truncation message */
         PRINTMSG(line, 1127, Caution, col);
      }
   }
   else {
      k = 0;
      for (i = 0; i < new_word_size; i++) {
         if (k >= old_word_size) {
            break;
         }
         the_constant[i] = CP_CONSTANT(CN_POOL_IDX(cn_idx) + k);
         k++;
      }

      while (i < new_word_size) {
         /* fill in pad */
         if (zero_pad) {
            the_constant[i] = 0;
         }
         else {
            char_ptr = (char *)&(the_constant[i]);
            for (l = 0; l < TARGET_CHARS_PER_WORD; l++) {
               char_ptr[l] = ' ';
            }
         }

         i++;
      }

      if (k < old_word_size) {
         /* issue truncation message */
         PRINTMSG(line, 1127, Caution, col);
      }

# ifdef _TARGET_OS_MAX
      if (TYP_LINEAR(type_idx) == Integer_1 ||
          TYP_LINEAR(type_idx) == Integer_2 ||
          TYP_LINEAR(type_idx) == Integer_4 ||
          TYP_LINEAR(type_idx) == Real_4    ||
          TYP_LINEAR(type_idx) == Logical_1 ||
          TYP_LINEAR(type_idx) == Logical_2 ||
          TYP_LINEAR(type_idx) == Logical_4) {

         the_constant[0] = the_constant[0] >> 32;
      }
# elif defined(_INTEGER_1_AND_2) && !defined(_TARGET_LITTLE_ENDIAN)

      if (on_off_flags.integer_1_and_2 &&
          (TYP_LINEAR(type_idx) == Integer_1 ||
           TYP_LINEAR(type_idx) == Integer_2 ||
           TYP_LINEAR(type_idx) == Logical_1 ||
           TYP_LINEAR(type_idx) == Logical_2)) {

         the_constant[0] = the_constant[0] >> (TARGET_BITS_PER_WORD - 
                           storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
      }
# endif
   }

# if defined(_INTEGER_1_AND_2)

   if (on_off_flags.integer_1_and_2) {

      if (TYP_LINEAR(type_idx) == Integer_1 || 
          TYP_LINEAR(type_idx) == Logical_1) {

         the_constant[0] = the_constant[0] & 0XFF;
      }
      else if (TYP_LINEAR(type_idx) == Integer_2 ||
               TYP_LINEAR(type_idx) == Logical_2) {

         the_constant[0] = the_constant[0] & 0XFFFF;
      }
   }
# endif

# ifdef _TARGET_OS_UNICOS

   /* to get proper sign extension on UNICOS pvp's for short ints, */
   /* convert the 64 bit typeless to short int.                    */

   if (TYP_LINEAR(type_idx) == Integer_1 ||
       TYP_LINEAR(type_idx) == Integer_2 ||
       TYP_LINEAR(type_idx) == Integer_4) {

      if (folder_driver( (char *) the_constant,
                         Integer_8,
                         NULL,
                         NULL_IDX,
                         another_constant,
                        &type_idx,
                         line,
                         col,
                         1,
                         Cvrt_Opr)) {

         for (i=0; i<MAX_WORDS_FOR_INTEGER; i++) {
            the_constant[i] = another_constant[i];
         }
      }
   }
# endif

   if (TYP_TYPE(type_idx) == Typeless &&
       CN_BOZ_CONSTANT(cn_idx)) {
      new_const_idx = ntr_boz_const_tbl(type_idx,
                                        the_constant);
   }
   else if (TYP_TYPE(type_idx) == Typeless &&
            CN_BOOLEAN_CONSTANT(cn_idx)) {
      new_const_idx = ntr_boolean_const_tbl(type_idx,
                                            the_constant);
   }
   else {

      if (TYP_TYPE(type_idx) == Real) {
         new_const_idx = ntr_unshared_const_tbl(type_idx,
                                                FALSE,
                                                the_constant);
      }
      else {
         new_const_idx = ntr_const_tbl(type_idx,
                                       FALSE,
                                       the_constant);
      }
   }

   TRACE (Func_Exit, "cast_typeless_constant", NULL);

   return(new_const_idx);

}  /* cast_typeless_constant */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	In cases where the default integer (logical) type has been changed by *|
|*      the command line, we must cast some arguments to library routines to  *|
|*      machine size integers. This occurs when default types are doubled on  *|
|*      solaris and when they are halved on mpp.                              *|
|*									      *|
|* Input parameters:							      *|
|*	opnd - subtree to put cvrt_opr over.                                  *|
|*	exp_desc - expression descriptor for that opnd.                       *|
|*									      *|
|* Output parameters:							      *|
|*	opnd - holds the new tree.                                            *|
|*      exp_desc - some fields have been changed, like type.                  *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void	cast_to_cg_default(opnd_type		*opnd,
			   expr_arg_type	*exp_desc)

{
   int			col;
   int			cvrt_idx;
   boolean		do_cast = FALSE;
   long_type		folded_const[MAX_WORDS_FOR_NUMERIC];
   int			line;
   int			type_idx;

   TRACE (Func_Entry, "cast_to_cg_default", NULL);

   if (exp_desc->type == Integer) {

      if (storage_bit_size_tbl[exp_desc->linear_type] != 
            storage_bit_size_tbl[TYP_LINEAR(CG_INTEGER_DEFAULT_TYPE)]) {

         do_cast = TRUE;
         type_idx = CG_INTEGER_DEFAULT_TYPE;
      }
   }
   else if (exp_desc->type == Logical) {

      if (storage_bit_size_tbl[exp_desc->linear_type] !=
            storage_bit_size_tbl[TYP_LINEAR(CG_LOGICAL_DEFAULT_TYPE)]) {

         do_cast = TRUE;
         type_idx = CG_LOGICAL_DEFAULT_TYPE;
      }
   }

   if (do_cast) {
      find_opnd_line_and_column(opnd, &line, &col);

      if (OPND_FLD((*opnd)) == CN_Tbl_Idx) {

         if (folder_driver((char *)&CN_CONST(OPND_IDX((*opnd))),
                           exp_desc->type_idx,
                           NULL,
                           NULL_IDX,
                           folded_const,
                          &type_idx,
                           line,
                           col,
                           1,
                           Cvrt_Opr)) {
            /* intentionally blank */
         }

         OPND_IDX((*opnd)) = ntr_const_tbl(type_idx,
                                           FALSE,
                                           folded_const);

      }
      else {
     
         NTR_IR_TBL(cvrt_idx);
         IR_OPR(cvrt_idx) = Cvrt_Opr;
         IR_TYPE_IDX(cvrt_idx) = type_idx;
         IR_LINE_NUM(cvrt_idx) = line;
         IR_COL_NUM(cvrt_idx)  = col;

         IR_RANK(cvrt_idx) = exp_desc->rank;

         COPY_OPND(IR_OPND_L(cvrt_idx), (*opnd));

         if (exp_desc->rank > 0) {
            IR_ARRAY_SYNTAX(cvrt_idx) = TRUE;
         }

         OPND_FLD((*opnd)) = IR_Tbl_Idx;
         OPND_IDX((*opnd)) = cvrt_idx;

         exp_desc->reference = FALSE;
         exp_desc->tmp_reference = FALSE;
      }

      exp_desc->type_idx    = type_idx;
      exp_desc->type        = TYP_TYPE(type_idx);
      exp_desc->linear_type = TYP_LINEAR(type_idx);
   }

   TRACE (Func_Exit, "cast_to_cg_default", NULL);

   return;

}  /* cast_to_cg_default */



/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void cast_opnd_to_type_idx(opnd_type	*opnd,
			   int		 type_idx)

{
   int			col;
   expr_arg_type	exp_desc;
   int			line;

   TRACE (Func_Entry, "cast_opnd_to_type_idx", NULL);

   exp_desc = init_exp_desc;

   if (OPND_FLD((*opnd)) == CN_Tbl_Idx) {
      exp_desc.type_idx = CN_TYPE_IDX(OPND_IDX((*opnd)));
   }
   else if (OPND_FLD((*opnd)) == AT_Tbl_Idx) {
      exp_desc.type_idx = ATD_TYPE_IDX(OPND_IDX((*opnd)));
   }
   else if (OPND_FLD((*opnd)) == IR_Tbl_Idx) {
      exp_desc.type_idx = IR_TYPE_IDX(OPND_IDX((*opnd)));
      exp_desc.rank = IR_RANK(OPND_IDX((*opnd)));
   }
   else {
# ifdef _DEBUG
      find_opnd_line_and_column(opnd, &line, &col);
      PRINTMSG(line, 626, Internal, col,
               "CN, AT, or IR_Tbl_Idx", "cast_opnd_to_type_idx");
# endif
   }

   exp_desc.linear_type = TYP_LINEAR(exp_desc.type_idx);
   exp_desc.type        = TYP_TYPE(exp_desc.type_idx);

   cast_to_type_idx(opnd, &exp_desc, type_idx);

   TRACE (Func_Exit, "cast_opnd_to_type_idx", NULL);

   return;

}  /* cast_opnd_to_type_idx */



/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Cast an arbitrary opnd to type described in typ_tbl[type_idx].        *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void	cast_to_type_idx(opnd_type		*opnd,
			 expr_arg_type		*exp_desc,
			 int			 type_idx)

{
   char                 *char_ptr1;
   char                 *char_ptr2;
   int                  cn_idx;
   int                  col;
   int                  cvrt_idx;
   long_type            folded_const[MAX_WORDS_FOR_NUMERIC];
   long64               i;
   int                  line;

   TRACE (Func_Entry, "cast_to_type_idx", NULL);

   if ((TYP_TYPE(type_idx) != Character &&
        TYP_LINEAR(type_idx) != exp_desc->linear_type) ||
       (TYP_TYPE(type_idx) == Character &&
        TYP_FLD(type_idx) == CN_Tbl_Idx &&
        TYP_FLD(exp_desc->type_idx) == CN_Tbl_Idx &&
        fold_relationals(TYP_IDX(type_idx),
                         TYP_IDX(exp_desc->type_idx),
                         Ne_Opr))) {

      find_opnd_line_and_column(opnd, &line, &col);

      if (exp_desc->linear_type == Short_Typeless_Const) {
         OPND_IDX((*opnd)) = cast_typeless_constant(OPND_IDX((*opnd)),
                                                    type_idx,
                                                    line,
                                                    col);

      }
      else if (OPND_FLD((*opnd)) == CN_Tbl_Idx) {

         if (TYP_TYPE(type_idx) == Character) {
            cn_idx = ntr_const_tbl(type_idx, TRUE, NULL);
            char_ptr1 = (char *)&CN_CONST(OPND_IDX((*opnd)));
            char_ptr2 = (char *)&CN_CONST(cn_idx);

            for (i = 0;
                 i < CN_INT_TO_C(TYP_IDX(exp_desc->type_idx)) &&
                    i < CN_INT_TO_C(TYP_IDX(type_idx));
                 i++) {
               char_ptr2[i] = char_ptr1[i];
            }

            for (; i < CN_INT_TO_C(TYP_IDX(type_idx)); i++) {
               char_ptr2[i] = ' ';
            }

            while ((i % TARGET_CHARS_PER_WORD) != 0) {
               char_ptr2[i] = ' ';
               i++;
            }

            OPND_IDX((*opnd)) = cn_idx;
            
            if (compare_cn_and_value(TYP_IDX(type_idx),
                                     MAX_CHARS_IN_TYPELESS,
                                     Le_Opr)) {
               exp_desc->linear_type = Short_Char_Const;
            }
            else {
               /* assume one byte character for now */
               exp_desc->linear_type = Character_1;
            }
         }
         else {
            if (folder_driver((char *)&CN_CONST(OPND_IDX((*opnd))),
                              exp_desc->type_idx,
                              NULL,
                              NULL_IDX,
                              folded_const,
                             &type_idx,
                              line,
                              col,
                              1,
                              Cvrt_Opr)) {
               /* intentionally blank */
            }

            OPND_IDX((*opnd)) = ntr_const_tbl(type_idx,
                                              FALSE,
                                              folded_const);
         }
      }
# if _DEBUG
      else if (TYP_TYPE(type_idx) == Character) {
         PRINTMSG(line, 626, Internal, col,
                  "non character operand",
                  "cast_to_type_idx");
      }
# endif
      else {

         NTR_IR_TBL(cvrt_idx);
         IR_OPR(cvrt_idx) = Cvrt_Opr;
         IR_RANK(cvrt_idx) = exp_desc->rank;

         IR_TYPE_IDX(cvrt_idx) = type_idx;
         IR_LINE_NUM(cvrt_idx) = line;
         IR_COL_NUM(cvrt_idx)  = col;

         COPY_OPND(IR_OPND_L(cvrt_idx), (*opnd));

         if (exp_desc->rank > 0) {
            IR_ARRAY_SYNTAX(cvrt_idx) = TRUE;
         }

         OPND_FLD((*opnd)) = IR_Tbl_Idx;
         OPND_IDX((*opnd)) = cvrt_idx;

         exp_desc->reference = FALSE;
         exp_desc->tmp_reference = FALSE;
      }

      exp_desc->type_idx    = type_idx;
      exp_desc->type        = TYP_TYPE(type_idx);
      exp_desc->linear_type = TYP_LINEAR(type_idx);

      if (exp_desc->type == Character) {
         OPND_FLD(exp_desc->char_len) = TYP_FLD(exp_desc->type_idx);
         OPND_IDX(exp_desc->char_len) = TYP_IDX(exp_desc->type_idx);
      }
   }

   TRACE (Func_Exit, "cast_to_type_idx", NULL);

   return;

}  /* cast_to_type_idx */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	set up a logical constant value in an integer array depending on      *|
|*      kind type and platform.                                               *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

int	set_up_logical_constant(long_type	*the_constant, 
			        int		type_idx,
			        int		value,
			        boolean		enter_con)

{
   int	cn_idx;


   TRACE (Func_Entry, "set_up_logical_constant", NULL);

/* BRIANJ KAYKAY - Should this use arith? */

# if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
   if (TYP_LINEAR(type_idx) == Logical_8) {
# if defined(_HOST_LITTLE_ENDIAN) && defined(_TARGET_LITTLE_ENDIAN)
      *(long long *)the_constant = value;
# else
      the_constant[0] = 0;
      the_constant[1] = value;
# endif
   }
   else {
      the_constant[0] = value;
   }
# else
   the_constant[0] = value;
# endif

   if (enter_con) {
      cn_idx = ntr_const_tbl(type_idx,
                             FALSE,
                             the_constant);
   }
   else {
      cn_idx = NULL_IDX;
   }

   TRACE (Func_Exit, "set_up_logical_constant", NULL);

   return(cn_idx);

}  /* set_up_logical_constant */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

boolean validate_char_len(opnd_type     *result_opnd,
                          expr_arg_type *exp_desc)

{
   int                  ch_asg_idx;
   int                  col;
   opnd_type            length_opnd;
   int                  line;
   expr_arg_type        loc_exp_desc;
   boolean              ok = TRUE;
   cif_usage_code_type  save_xref_state;
   int                  tmp_idx;

   TRACE (Func_Entry, "validate_char_len", NULL);

   if (exp_desc->type == Character          &&
       (exp_desc->char_len.fld != TYP_FLD(exp_desc->type_idx) ||
        exp_desc->char_len.idx != TYP_IDX(exp_desc->type_idx) ||
        (OPND_FLD((*result_opnd))         == IR_Tbl_Idx &&
         IR_OPR(OPND_IDX((*result_opnd))) == Concat_Opr))) {

      find_opnd_line_and_column(result_opnd, &line, &col);

# ifdef _DEBUG
      if (exp_desc->char_len.fld == NO_Tbl_Idx) {
         PRINTMSG(line, 1018, Internal, col);
      }
# endif

      loc_exp_desc.rank = 0;

      if (OPND_FLD((*result_opnd))         == IR_Tbl_Idx &&
          IR_OPR(OPND_IDX((*result_opnd))) == Concat_Opr) {

         get_concat_len(OPND_IDX((*result_opnd)), &length_opnd);
      }
      else {
         COPY_OPND(length_opnd, (exp_desc->char_len));
      }

      save_xref_state = xref_state;
      xref_state      = CIF_No_Usage_Rec;
      ok = expr_semantics(&length_opnd, &loc_exp_desc);
      xref_state      = save_xref_state;

      COPY_OPND((exp_desc->char_len), length_opnd);

      if (loc_exp_desc.constant) {
         CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);

         TYP_TYPE(TYP_WORK_IDX)         = Character;
         TYP_LINEAR(TYP_WORK_IDX)       = CHARACTER_DEFAULT_TYPE;
         TYP_CHAR_CLASS(TYP_WORK_IDX)   = Const_Len_Char;
         TYP_FLD(TYP_WORK_IDX)          = CN_Tbl_Idx;
         TYP_IDX(TYP_WORK_IDX)          = OPND_IDX(length_opnd);
         exp_desc->type_idx             = ntr_type_tbl();
         exp_desc->type                 = Character;
         exp_desc->linear_type          = CHARACTER_DEFAULT_TYPE;
      }
      else { /* non constant character length means an alloc'd item */

         GEN_COMPILER_TMP_ASG(ch_asg_idx,
                              tmp_idx,
                              TRUE,     /* Semantics done */
                              line,
                              col,
                              loc_exp_desc.type_idx,
                              Priv);

         COPY_OPND(IR_OPND_R(ch_asg_idx), length_opnd);

         gen_sh(Before, Assignment_Stmt, stmt_start_line,
                         stmt_start_col, FALSE, FALSE, TRUE);

         SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx;
         SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

         CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);

         TYP_TYPE(TYP_WORK_IDX)         = Character;
         TYP_LINEAR(TYP_WORK_IDX)       = CHARACTER_DEFAULT_TYPE;
         TYP_CHAR_CLASS(TYP_WORK_IDX)   = Var_Len_Char;
         TYP_FLD(TYP_WORK_IDX)          = AT_Tbl_Idx;
         TYP_IDX(TYP_WORK_IDX)          = tmp_idx;
         TYP_ORIG_LEN_IDX(TYP_WORK_IDX) = tmp_idx;
         exp_desc->type_idx             = ntr_type_tbl();
         exp_desc->type                 = Character;
         exp_desc->linear_type          = CHARACTER_DEFAULT_TYPE;
      }
   }

   if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx &&
       (IR_OPR(OPND_IDX((*result_opnd))) == Substring_Opr ||
        IR_OPR(OPND_IDX((*result_opnd))) == Whole_Substring_Opr)) {

      IR_TYPE_IDX(OPND_IDX((*result_opnd))) = exp_desc->type_idx;
   }


   TRACE (Func_Exit, "validate_char_len", NULL);

   return(ok);

}  /* validate_char_len */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void gen_runtime_checks(opnd_type	*top_opnd)

{
   int		ir_idx;
   int		list_idx;
   opnd_type	opnd;

   TRACE (Func_Entry, "gen_runtime_checks", NULL);

   switch (OPND_FLD((*top_opnd))) {
   case IR_Tbl_Idx:
      ir_idx = OPND_IDX((*top_opnd));

      if ((IR_OPR(ir_idx) == Subscript_Opr ||
           IR_OPR(ir_idx) == Section_Subscript_Opr) &&
#ifdef KEY /* Bug 7969 */
          needs_bounds_check(ir_idx, FALSE)
#else /* KEY Bug 7969 */
          needs_bounds_check(ir_idx)
#endif /* KEY Bug 7969 */
	  ) {

#ifdef KEY /* Bug 7969 */
         gen_runtime_bounds(ir_idx, FALSE);
#else /* KEY Bug 7969 */
         gen_runtime_bounds(ir_idx);
#endif /* KEY Bug 7969 */
      }
      else if (cmd_line_flags.runtime_substring &&
               IR_OPR(ir_idx) == Substring_Opr  &&
               ATD_CLASS(find_left_attr(&IR_OPND_L(ir_idx))) != Compiler_Tmp) {
#ifdef KEY /* Bug 7969 */
         gen_runtime_substring(ir_idx, FALSE);
#else /* KEY Bug 7969 */
         gen_runtime_substring(ir_idx);
#endif /* KEY Bug 7969 */
      }

      COPY_OPND(opnd, IR_OPND_L(ir_idx));
      gen_runtime_checks(&opnd);

      COPY_OPND(opnd, IR_OPND_R(ir_idx));
      gen_runtime_checks(&opnd);
      break;

   case IL_Tbl_Idx:
      list_idx = OPND_IDX((*top_opnd));

      while (list_idx) {
         COPY_OPND(opnd, IL_OPND(list_idx));
         gen_runtime_checks(&opnd);

         list_idx = IL_NEXT_LIST_IDX(list_idx);
      }
      break;
   }

   TRACE (Func_Exit, "gen_runtime_checks", NULL);

   return;

}  /* gen_runtime_checks */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void gen_runtime_conformance(opnd_type 		*l_opnd,
                             expr_arg_type	*l_exp_desc,
                             opnd_type		*r_opnd,   /* BRIANJ -not used*/
                             expr_arg_type	*r_exp_desc)

{
   int			col;
   int			i;
   expr_arg_type	left_exp_desc;
   int			line;
   expr_arg_type	right_exp_desc;

   TRACE (Func_Entry, "gen_runtime_conformance", NULL);

   left_exp_desc = *l_exp_desc;
   right_exp_desc = *r_exp_desc;

   find_opnd_line_and_column(l_opnd, &line, &col);

# ifdef _DEBUG
   if (defer_stmt_expansion) {
      PRINTMSG(line, 626, Internal, col,
               "defer_stmt_expansion to be FALSE", 
               "gen_runtime_conformance");
   }
# endif

   for (i = 0; i < left_exp_desc.rank; i++) {
       gen_conform_check_call(&(left_exp_desc.shape[i]),
                              &(right_exp_desc.shape[i]),
                              i + 1,
                              line,
                              col);
   }

   TRACE (Func_Exit, "gen_runtime_conformance", NULL);

   return;

}  /* gen_runtime_conformance */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

#ifdef KEY /* Bug 7969 */
/*
 * Generate runtime check for substring bounds
 * substring_idx	IL_Tbl_Idx for Substring_Opr
 * even_if_const	if true, generate check even if it could have been
 *			checked at compile time
 */
void gen_runtime_substring(int substring_idx, boolean even_if_const)
#else /* KEY Bug 7969 */
void gen_runtime_substring(int		substring_idx)
#endif /* KEY Bug 7969 */

{
   int		attr_idx;
   int		list_idx;
   int		line;
   int		col;
   opnd_type	size_opnd;
   opnd_type	start_opnd;
   opnd_type	subln_opnd;

   TRACE (Func_Entry, "gen_runtime_substring", NULL);

#ifdef KEY /* Bug 7969 */
   /* Avoid duplicates due to calls in both substring_opr_handler and
    * gen_runtime_checks */
   if (IR_BOUNDS_DONE(substring_idx)) {
     return;
   }
#endif /* KEY Bug 7969 */

   attr_idx = find_base_attr(&IR_OPND_L(substring_idx), &line, &col);

# ifdef _DEBUG
   if (defer_stmt_expansion) {
      PRINTMSG(line, 626, Internal, col,
               "defer_stmt_expansion to be FALSE", 
               "gen_runtime_substring");
   }
# endif

   list_idx = IR_IDX_R(substring_idx);

   OPND_FLD(size_opnd) = TYP_FLD(ATD_TYPE_IDX(attr_idx));
   OPND_IDX(size_opnd) = TYP_IDX(ATD_TYPE_IDX(attr_idx));
   OPND_LINE_NUM(size_opnd) = line;
   OPND_COL_NUM(size_opnd)  = col;

   COPY_OPND(start_opnd, IL_OPND(list_idx));
   list_idx = IL_NEXT_LIST_IDX(list_idx);
   list_idx = IL_NEXT_LIST_IDX(list_idx);

# ifdef _DEBUG
   if (list_idx == NULL_IDX) {
      PRINTMSG(line, 626, Internal, col,
                     "substring length",
                     "gen_runtime_substring");
   }
# endif

   COPY_OPND(subln_opnd, IL_OPND(list_idx));

   if (OPND_FLD(start_opnd) == CN_Tbl_Idx &&
#ifdef KEY /* Bug 7969 */
       (!even_if_const) &&
#endif /* KEY Bug 7969 */
       OPND_FLD(subln_opnd) == CN_Tbl_Idx &&
       OPND_FLD(size_opnd) == CN_Tbl_Idx) {

   }
   else {
      gen_sbounds_check_call(AT_OBJ_NAME_PTR(attr_idx), 
                             &size_opnd,
                             &start_opnd,
                             &subln_opnd,
                             line,
                             col
#ifdef KEY /* Bug 7969 */
                             , even_if_const
#endif /* KEY Bug 7969 */
			     );

      IR_BOUNDS_DONE(substring_idx) = TRUE;
   }
   

   TRACE (Func_Exit, "gen_runtime_substring", NULL);

   return;

}  /* gen_runtime_substring */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void gen_runtime_ptr_chk(opnd_type	*dv_opnd)

{
   int		attr_idx;
   int		bd_idx;
   int		col;
   int		left_attr;
   int		line;

   TRACE (Func_Entry, "gen_runtime_ptr_chk", NULL);

   attr_idx = find_base_attr(dv_opnd, &line, &col);
   left_attr = find_left_attr(dv_opnd);

   bd_idx = ATD_ARRAY_IDX(attr_idx);

   if (ATD_CLASS(left_attr) == Compiler_Tmp) {
      goto EXIT;
   }

   if (ATD_POINTER(attr_idx)) {
      gen_ptr_chk_call(AT_OBJ_NAME_PTR(attr_idx),
                       1,		/* means POINTER */
                       dv_opnd,
                       line,
                       col);
   }
   else if (ATD_ALLOCATABLE(attr_idx)) {
      gen_ptr_chk_call(AT_OBJ_NAME_PTR(attr_idx),
                       2,		/* means ALLOCATABLE ARRAY */
                       dv_opnd,
                       line,
                       col);
   }
   else if (bd_idx &&
            BD_ARRAY_CLASS(bd_idx) == Assumed_Shape) {
      gen_ptr_chk_call(AT_OBJ_NAME_PTR(attr_idx),
                       3,		/* means ASSUMED SHAPE ARRAY */
                       dv_opnd,
                       line,
                       col);
   }

EXIT:

   TRACE (Func_Exit, "gen_runtime_ptr_chk", NULL);

   return;

}  /* gen_runtime_ptr_chk */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

#ifdef KEY /* Bug 7969 */
/*
 * Generate runtime check for subscript bounds
 * substring_idx	IL_Tbl_Idx for Subcript_Opr or Section_Subscript_Opr
 * even_if_const	if true, generate check even if it could have been
 *			checked at compile time
 */
void gen_runtime_bounds(int sub_idx, boolean even_if_const)
#else /* KEY Bug 7969 */
void gen_runtime_bounds(int	sub_idx)
#endif /* KEY Bug 7969 */

{
   int		attr_idx;
   int		bd_idx;
   int		col;
   int		dim;
   opnd_type	end_opnd;
   opnd_type	inc_opnd;
   int		ir_idx2;
   opnd_type	lb_opnd;
   int		line;
   int		list_idx;
   int		list_idx2;
   int		minus_idx;
   opnd_type	opnd;
   opnd_type	opnd2;
   int		plus_idx;
   opnd_type	start_opnd;
   opnd_type	ub_opnd;

   TRACE (Func_Entry, "gen_runtime_bounds", NULL);

#ifdef KEY /* Bug 7969 */
   if (IR_BOUNDS_DONE(sub_idx)) {
     return;
   }
#endif /* KEY Bug 7969 */

   attr_idx = find_base_attr(&IR_OPND_L(sub_idx), &line, &col);


# ifdef _DEBUG
   if (defer_stmt_expansion) {
      PRINTMSG(line, 626, Internal, col,
               "defer_stmt_expansion to be FALSE", 
               "gen_runtime_bounds");
   }
# endif

   bd_idx = ATD_ARRAY_IDX(attr_idx);

   list_idx = IR_IDX_R(sub_idx);
   dim = 1;

   while (list_idx != NULL_IDX) {
#ifdef KEY /* Bug 7969 */
      opnd_type *p_ub_opnd = &ub_opnd;
#else /* KEY Bug 7969 */
      if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size &&
          dim == BD_RANK(bd_idx)) {
         break;
      }
#endif /* KEY Bug 7969 */

      if (IL_VECTOR_SUBSCRIPT(list_idx)) {
         list_idx = IL_NEXT_LIST_IDX(list_idx);
         dim++;
         continue;
      }

      if (ATD_IM_A_DOPE(attr_idx)) {
         COPY_OPND(opnd, IR_OPND_L(sub_idx));

         if (OPND_FLD(opnd) == IR_Tbl_Idx &&
             IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr) {

            COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
         }

         gen_dv_access_low_bound(&lb_opnd, &opnd, dim);

         copy_subtree(&lb_opnd, &opnd2, 0, 0);

         ir_idx2 = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
                     Dv_Access_Extent, SA_INTEGER_DEFAULT_TYPE,
                                 line, col,
                         NO_Tbl_Idx, NULL_IDX);
         IR_DV_DIM(ir_idx2) = dim;

         plus_idx = gen_ir(OPND_FLD(opnd2), OPND_IDX(opnd2),
                       Plus_Opr, SA_INTEGER_DEFAULT_TYPE, line, col,
                           IR_Tbl_Idx, ir_idx2);

         minus_idx = gen_ir(IR_Tbl_Idx, plus_idx,
                        Minus_Opr, SA_INTEGER_DEFAULT_TYPE, line, col,
                            CN_Tbl_Idx, CN_INTEGER_ONE_IDX);

         gen_opnd(&ub_opnd, minus_idx, IR_Tbl_Idx, line, col);
      }
      else {
         gen_opnd(&lb_opnd, BD_LB_IDX(bd_idx,dim), 
                  BD_LB_FLD(bd_idx, dim), line, col);
#ifdef KEY /* Bug 7969 */
	 /* For final upper bound of assumed-size, use nil pointer to tell
	  * gen_[r]bounds_check_call() not to test against it. */
	 if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size && dim == BD_RANK(bd_idx)) {
	    p_ub_opnd = 0;
	 }
	else
#endif /* KEY Bug 7969 */
         gen_opnd(&ub_opnd, BD_UB_IDX(bd_idx,dim), 
                  BD_UB_FLD(bd_idx, dim), line, col);
      }

      if (IL_FLD(list_idx) == IR_Tbl_Idx &&
          IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) {

         list_idx2 = IR_IDX_L(IL_IDX(list_idx));
         COPY_OPND(start_opnd, IL_OPND(list_idx2));
         copy_subtree(&start_opnd, &start_opnd, 0, 0);

         list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
         COPY_OPND(end_opnd, IL_OPND(list_idx2));
         copy_subtree(&end_opnd, &end_opnd, 0, 0);

         list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
         COPY_OPND(inc_opnd, IL_OPND(list_idx2));
         copy_subtree(&inc_opnd, &inc_opnd, 0, 0);

         if (OPND_FLD(lb_opnd) != CN_Tbl_Idx ||
#ifdef KEY /* Bug 7969 */
             even_if_const ||
#endif /* KEY Bug 7969 */
             OPND_FLD(ub_opnd) != CN_Tbl_Idx ||
             OPND_FLD(start_opnd) != CN_Tbl_Idx ||
             OPND_FLD(end_opnd) != CN_Tbl_Idx ||
             OPND_FLD(inc_opnd) != CN_Tbl_Idx) {

            gen_rbounds_check_call(AT_OBJ_NAME_PTR(attr_idx),
                                   &lb_opnd,
#ifdef KEY /* Bug 7969 */
                                   p_ub_opnd,
#else /* KEY Bug 7969 */
                                   &ub_opnd,
#endif /* KEY Bug 7969 */
                                   &start_opnd,
                                   &end_opnd,
                                   &inc_opnd,
                                   dim,
                                   line,
                                   col);
            IR_BOUNDS_DONE(sub_idx) = TRUE;
         }
      }
# if 0
      else if (IL_VECTOR_SUBSCRIPT(list_idx)) {
         /* not supported yet. These are pulled off of IO */
      }
# endif
      else if (IL_FLD(list_idx) != CN_Tbl_Idx ||
#ifdef KEY /* Bug 7969 */
	       even_if_const ||
#endif /* KEY Bug 7969 */
               OPND_FLD(lb_opnd) != CN_Tbl_Idx ||
               OPND_FLD(ub_opnd) != CN_Tbl_Idx) {

         COPY_OPND(start_opnd, IL_OPND(list_idx));
         copy_subtree(&start_opnd, &start_opnd, 0, 0);

         gen_bounds_check_call(AT_OBJ_NAME_PTR(attr_idx),
                               &lb_opnd,
#ifdef KEY /* Bug 7969 */
                               p_ub_opnd,
#else /* KEY Bug 7969 */
                               &ub_opnd,
#endif /* KEY Bug 7969 */
                               &start_opnd,
                               dim,
                               line, 
                               col);

         IR_BOUNDS_DONE(sub_idx) = TRUE;
      }

      list_idx = IL_NEXT_LIST_IDX(list_idx);
      dim++;
   }

   TRACE (Func_Exit, "gen_runtime_bounds", NULL);

   return;

}  /* gen_runtime_bounds */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	generate the call to the conformance check lib routine (which only    *|
|*      issues the message). When support exists for a conform_opr, this      *|
|*      routine will generate that.                                           *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

static void gen_conform_check_call(opnd_type *l_shape, opnd_type *r_shape,
                                   int dim, int line, int col)

{
   int			call_idx;
   opnd_type		cond_opnd;
   int			dim_idx;
   int			end_sh_idx;
   expr_arg_type	exp_desc;
   int			ir_idx;
   int			line_idx;
   int			list_idx;
   int			max_idx;
   int			max_idx2;
   opnd_type		opnd;
   int			save_curr_stmt_sh_idx;
   expr_mode_type	save_expr_mode;
   cif_usage_code_type	save_xref_state;
   int			start_sh_idx;
   int			tmp_idx;


   TRACE (Func_Entry, "gen_conform_check_call", NULL);

   save_curr_stmt_sh_idx = curr_stmt_sh_idx;

   /* save the bounding stmts for the gen_if_stmt call */

   start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
   end_sh_idx = curr_stmt_sh_idx;

   /* generate the if condition */

   GEN_MAX_ZERO_IR(max_idx, (*l_shape), line, col);

   GEN_MAX_ZERO_IR(max_idx2, (*r_shape), line, col);

   ir_idx = gen_ir(IR_Tbl_Idx, max_idx,
               Ne_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                   IR_Tbl_Idx, max_idx2);

   gen_opnd(&cond_opnd, ir_idx, IR_Tbl_Idx, line, col);

   if (glb_tbl_idx[Conform_Attr_Idx] == NULL_IDX) {
      glb_tbl_idx[Conform_Attr_Idx] = create_lib_entry_attr(
                                                   CONFORM_LIB_ENTRY,
                                                   CONFORM_NAME_LEN,
                                                   line,
                                                   col);
   }

   ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Conform_Attr_Idx]);

   /* count (= 0) must be static temp */

   tmp_idx = gen_initialized_tmp(CN_INTEGER_ZERO_IDX, line, col);

   line_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, line);
   dim_idx  = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, dim);

   list_idx = gen_il(4, TRUE, line, col,
                     CN_Tbl_Idx, put_file_name_in_cn(line),	/* file name */
                     CN_Tbl_Idx, line_idx,                      /* line */
                     CN_Tbl_Idx, dim_idx,                       /* dim */
                     AT_Tbl_Idx, tmp_idx);			/* count */

   call_idx = gen_ir(AT_Tbl_Idx, glb_tbl_idx[Conform_Attr_Idx],
                 Call_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                     IL_Tbl_Idx, list_idx);

   gen_sh(Before, Call_Stmt, line, col,
          FALSE, FALSE, TRUE);
   curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
   SH_IR_IDX(curr_stmt_sh_idx) = call_idx;
   SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

   gen_opnd(&opnd, call_idx, IR_Tbl_Idx, line, col);

   save_xref_state = xref_state;
   xref_state      = CIF_No_Usage_Rec;
   save_expr_mode  = expr_mode;
   expr_mode       = Regular_Expr;

   exp_desc        = init_exp_desc;
   call_list_semantics(&opnd, &exp_desc, FALSE);
   xref_state = save_xref_state;
   expr_mode  = save_expr_mode;

#ifdef KEY /* Bug 8502 */
   int if_sh_idx =
#endif /* KEY Bug 8502 */
   gen_if_stmt(&cond_opnd, 
               SH_NEXT_IDX(start_sh_idx),
               SH_PREV_IDX(end_sh_idx),
               NULL_IDX,
               NULL_IDX,
               line,
               col);
#ifdef KEY /* Bug 8502 */
   isolate_if_predicate(if_sh_idx);
#endif /* KEY Bug 8502 */

   curr_stmt_sh_idx = save_curr_stmt_sh_idx;

   TRACE (Func_Exit, "gen_conform_check_call", NULL);

   return;

}  /* gen_conform_check_call */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      generate the call to the bounds check lib routine (which only         *|
|*      issues the message). When support exists for a bounds_opr, this       *|
|*      routine will generate that.                                           *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

static void gen_bounds_check_call(char *var,
				  opnd_type *lb_opnd,
                                  opnd_type *ub_opnd,
				  opnd_type *subscript,
                                  int dim,
				  int line,
				  int col)

{
   int                  call_idx;
   opnd_type		cond_opnd;
   int			dim_idx;
   int			end_sh_idx;
   expr_arg_type        exp_desc;
   int			gt_idx;
   int			line_idx;
   int                  list_idx;
   int			lt_idx;
   int			or_idx;
   opnd_type            opnd;
   int                  save_curr_stmt_sh_idx;
   expr_mode_type       save_expr_mode;
   cif_usage_code_type  save_xref_state;
   int			start_sh_idx;
   int                  tmp_idx;


   TRACE (Func_Entry, "gen_bounds_check_call", NULL);

   save_curr_stmt_sh_idx = curr_stmt_sh_idx;

   /* save the bounding stmts for the gen_if_stmt call */

   start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
   end_sh_idx = curr_stmt_sh_idx;

   /* cond_opnd = (subscript < lb) .or. (subscript > ub) */

   /* subscript < lb */

   lt_idx = gen_ir(OPND_FLD((*subscript)), OPND_IDX((*subscript)),
               Lt_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                   OPND_FLD((*lb_opnd)), OPND_IDX((*lb_opnd)));

   /* subscript > ub */
#ifdef KEY /* Bug 7969 */
   /* Skip comparison against ub when it is null for last dimension of an
    * assumed-size array */
   if (ub_opnd == 0) {
     or_idx = lt_idx;
     ub_opnd = lb_opnd;
   }
   else {
#endif /* KEY Bug 7969 */
   gt_idx = gen_ir(OPND_FLD((*subscript)), OPND_IDX((*subscript)),
               Gt_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                   OPND_FLD((*ub_opnd)), OPND_IDX((*ub_opnd)));

   or_idx = gen_ir(IR_Tbl_Idx, lt_idx,
               Or_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                   IR_Tbl_Idx, gt_idx);
#ifdef KEY /* Bug 7969 */
   }
#endif /* KEY Bug 7969 */


   gen_opnd(&cond_opnd, or_idx, IR_Tbl_Idx, line, col);

   if (glb_tbl_idx[Bounds_Attr_Idx] == NULL_IDX) {
      glb_tbl_idx[Bounds_Attr_Idx] = create_lib_entry_attr(
                                                   BOUNDS_LIB_ENTRY,
                                                   BOUNDS_NAME_LEN,
                                                   line,
                                                   col);
	/* Bug COMPILER-8762 */
	ATP_PURE(glb_tbl_idx[Bounds_Attr_Idx]) = TRUE;
   }

   ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Bounds_Attr_Idx]);

   /* count (= 0) must be static temp */

   tmp_idx  = gen_initialized_tmp(CN_INTEGER_ZERO_IDX, line, col);
   line_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, line);
   dim_idx  = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, dim);

   list_idx = gen_il(8, TRUE, line, col,
                     CN_Tbl_Idx, put_file_name_in_cn(line),     /* file name */
                     CN_Tbl_Idx, line_idx,
                     CN_Tbl_Idx, put_c_str_in_cn(var),	    /* var name */
                     CN_Tbl_Idx, dim_idx,
                     OPND_FLD((*lb_opnd)), OPND_IDX((*lb_opnd)),/* lower bd */
                     OPND_FLD((*ub_opnd)), OPND_IDX((*ub_opnd)),/* upper bd */
                     OPND_FLD((*subscript)), OPND_IDX((*subscript)),
                     AT_Tbl_Idx, tmp_idx);                      /* count */

   call_idx = gen_ir(AT_Tbl_Idx, glb_tbl_idx[Bounds_Attr_Idx],
                 Call_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                     IL_Tbl_Idx, list_idx);

   gen_sh(Before, Call_Stmt, line, col,
          FALSE, FALSE, TRUE);
   curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
   SH_IR_IDX(curr_stmt_sh_idx) = call_idx;
   SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

   gen_opnd(&opnd, call_idx, IR_Tbl_Idx, line, col);

   save_xref_state = xref_state;
   xref_state      = CIF_No_Usage_Rec;
   save_expr_mode  = expr_mode;
   expr_mode       = Regular_Expr;

   exp_desc        = init_exp_desc;
   call_list_semantics(&opnd, &exp_desc, FALSE);
   xref_state = save_xref_state;
   expr_mode  = save_expr_mode;

#ifdef KEY /* Bug 8502 */
   int if_sh_idx =
#endif /* KEY Bug 8502 */
   /* Instead of using the start_sh_idx from above, one can just use
    * curr_stmt_sh_idx and take SH_PREV_IDX of it. The end result will
    * be the same since we only have "Before" insertions in here.
    * The advantage of using curr_stmt_sh_idx instead is that when
    * called during decl_semantics the stmt to check might be standalone
    * without a stmt chain leading up to it and start_sh_idx would then
    * be 0, causing a segfault in gen_if_stmt.
    */
   gen_if_stmt(&cond_opnd,
               SH_PREV_IDX(curr_stmt_sh_idx),
               SH_PREV_IDX(end_sh_idx),
               NULL_IDX,
               NULL_IDX,
               line,
               col);
#ifdef KEY /* Bug 8502 */
   isolate_if_predicate(if_sh_idx);
#endif /* KEY Bug 8502 */

   curr_stmt_sh_idx = save_curr_stmt_sh_idx;

   TRACE (Func_Exit, "gen_bounds_check_call", NULL);

   return;

}  /* gen_bounds_check_call */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      generate the call to the bounds check lib routine (which only         *|
|*      issues the message). When support exists for a bounds_opr, this       *|
|*      routine will generate that. This is for range checks for sections.    *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

static void gen_rbounds_check_call(char 	*var, 
                                   opnd_type 	*lb_opnd,
                                   opnd_type 	*ub_opnd, 
                                   opnd_type 	*start_opnd,
                                   opnd_type 	*end_opnd,
                                   opnd_type 	*inc_opnd,
                                   int 		dim, 
                                   int 		line, 
                                   int 		col)

{
   int                  call_idx;
   opnd_type            cond_opnd;
   int                  dim_idx;
   int                  end_sh_idx;
   expr_arg_type        exp_desc;
   int                  line_idx;
   int                  list_idx;
   opnd_type            opnd;
   int                  save_curr_stmt_sh_idx;
   expr_mode_type       save_expr_mode;
   cif_usage_code_type  save_xref_state;
   int                  start_sh_idx;
   int                  tmp_idx;


   TRACE (Func_Entry, "gen_rbounds_check_call", NULL);

   save_curr_stmt_sh_idx = curr_stmt_sh_idx;

   /* save the bounding stmts for the gen_if_stmt call */

   start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
   end_sh_idx = curr_stmt_sh_idx;

   gen_rbounds_condition(&cond_opnd,
                         start_opnd,
                         end_opnd,
                         inc_opnd,
                         lb_opnd,
                         ub_opnd,
                         line,
                         col);

#ifdef KEY /* Bug 7969 */
   /* Assumed-size final upper bound: treat as if it were same as lower */
   if (ub_opnd == 0) {
     ub_opnd = lb_opnd;
   }
#endif /* KEY Bug 7969 */

   if (glb_tbl_idx[Rbounds_Attr_Idx] == NULL_IDX) {
      glb_tbl_idx[Rbounds_Attr_Idx] = create_lib_entry_attr(
                                                   RBOUNDS_LIB_ENTRY,
                                                   RBOUNDS_NAME_LEN,
                                                   line,
                                                   col);
	/* Bug COMPILER-8762 */
	ATP_PURE(glb_tbl_idx[Rbounds_Attr_Idx]) = TRUE;
   }

   ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Rbounds_Attr_Idx]);

   /* count (= 0) must be static temp */

   tmp_idx  = gen_initialized_tmp(CN_INTEGER_ZERO_IDX, line, col);
   line_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, line);
   dim_idx  = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, dim);
   list_idx = gen_il(10, TRUE, line, col,
                     CN_Tbl_Idx, put_file_name_in_cn(line),     /* file name */
                     CN_Tbl_Idx, line_idx,                      /* line */
                     CN_Tbl_Idx, put_c_str_in_cn(var),          /* var name */
                     CN_Tbl_Idx, dim_idx,                       /* dim */
                     OPND_FLD((*lb_opnd)), OPND_IDX((*lb_opnd)),/* lower bd */
                     OPND_FLD((*ub_opnd)), OPND_IDX((*ub_opnd)),/* upper bd */
                     OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)),
                     OPND_FLD((*end_opnd)), OPND_IDX((*end_opnd)),
                     OPND_FLD((*inc_opnd)), OPND_IDX((*inc_opnd)),
                     AT_Tbl_Idx, tmp_idx);                      /* count */

   call_idx = gen_ir(AT_Tbl_Idx, glb_tbl_idx[Rbounds_Attr_Idx],
                 Call_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                     IL_Tbl_Idx, list_idx);

   gen_sh(Before, Call_Stmt, line, col,
          FALSE, FALSE, TRUE);
   curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
   SH_IR_IDX(curr_stmt_sh_idx) = call_idx;
   SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

   gen_opnd(&opnd, call_idx, IR_Tbl_Idx, line, col);

   save_xref_state = xref_state;
   xref_state      = CIF_No_Usage_Rec;
   save_expr_mode  = expr_mode;
   expr_mode       = Regular_Expr;

   exp_desc        = init_exp_desc;
   call_list_semantics(&opnd, &exp_desc, FALSE);
   xref_state = save_xref_state;
   expr_mode  = save_expr_mode;

#ifdef KEY /* Bug 8502 */
   int if_sh_idx =
#endif /* KEY Bug 8502 */
   gen_if_stmt(&cond_opnd,
               SH_NEXT_IDX(start_sh_idx),
               SH_PREV_IDX(end_sh_idx),
               NULL_IDX,
               NULL_IDX,
               line,
               col);
#ifdef KEY /* Bug 8502 */
   isolate_if_predicate(if_sh_idx);
#endif /* KEY Bug 8502 */

   curr_stmt_sh_idx = save_curr_stmt_sh_idx;

   TRACE (Func_Exit, "gen_rbounds_check_call", NULL);

   return;

}  /* gen_rbounds_check_call */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      generate the call to the substring bounds check lib routine (which    *|
|*      issues the message). When support exists for a sbounds_opr, this      *|
|*      routine will generate that.                                           *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

/*
 * even_if_const	Generate full runtime check even if it could have been
 *			performed at compile time
 */
static void gen_sbounds_check_call(char *var, opnd_type *size_opnd, 
                                   opnd_type *start_opnd, 
                                   opnd_type *subln_opnd, int line, int col
#ifdef KEY /* Bug 7969 */
                                   , boolean even_if_const
#endif /* KEY Bug 7969 */
				   )

{
   int                  call_idx;
   opnd_type		cond_opnd;
   int			end_sh_idx;
   expr_arg_type        exp_desc;
   int			ir_idx;
   int			line_idx;
   int                  list_idx;
   int			lt_idx;
   int			minus_idx;
   int			minus_idx2;
   opnd_type            opnd;
   int			plus_idx;
   int			plus_idx2;
   int                  save_curr_stmt_sh_idx;
   expr_mode_type       save_expr_mode;
   cif_usage_code_type  save_xref_state;
   int			start_sh_idx;
   int                  tmp_idx;


   TRACE (Func_Entry, "gen_sbounds_check_call", NULL);

   save_curr_stmt_sh_idx = curr_stmt_sh_idx;

   /* save the bounding stmts for the gen_if_stmt call */

   start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
   end_sh_idx = curr_stmt_sh_idx;

   /* generate the condition. */

   /* if start is a constant, it is assumed that the start value */
   /* was checked at compile time and is not below 1.            */
   /* (1 + size_opnd) - (start_opnd + subln_opnd) < 0 => error   */
   /* else if start is not a constant ...                        */
   /* (((1 + size_opnd) - (start_opnd + subln_opnd)) .bor.       */
   /*                                      (start_opnd - 1)) < 0 */

   plus_idx = gen_ir(CN_Tbl_Idx, CN_INTEGER_ONE_IDX,
                 Plus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                     OPND_FLD((*size_opnd)), OPND_IDX((*size_opnd)));

   plus_idx2 = gen_ir(OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)),
                  Plus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                      OPND_FLD((*subln_opnd)), OPND_IDX((*subln_opnd)));

   minus_idx = gen_ir(IR_Tbl_Idx, plus_idx,
                  Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                      IR_Tbl_Idx, plus_idx2);

   if (OPND_FLD((*start_opnd)) == CN_Tbl_Idx
#ifdef KEY /* Bug 7969 */
      && (!even_if_const)
#endif /* KEY Bug 7969 */
      ) {
      lt_idx = gen_ir(IR_Tbl_Idx, minus_idx,
                  Lt_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                      CN_Tbl_Idx, CN_INTEGER_ZERO_IDX);
   }
   else {

      minus_idx2 = gen_ir(OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)),
                      Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                          CN_Tbl_Idx, CN_INTEGER_ONE_IDX);

      ir_idx = gen_ir(IR_Tbl_Idx, minus_idx2,
                  Bor_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                      IR_Tbl_Idx, minus_idx);

      lt_idx = gen_ir(IR_Tbl_Idx, ir_idx,
                  Lt_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                      CN_Tbl_Idx, CN_INTEGER_ZERO_IDX);
   }

   gen_opnd(&cond_opnd, lt_idx, IR_Tbl_Idx, line, col);

   if (glb_tbl_idx[Sbounds_Attr_Idx] == NULL_IDX) {
      glb_tbl_idx[Sbounds_Attr_Idx] = create_lib_entry_attr(
                                                   SBOUNDS_LIB_ENTRY,
                                                   SBOUNDS_NAME_LEN,
                                                   line,
                                                   col);
	/* Bug COMPILER-8762 */
	ATP_PURE(glb_tbl_idx[Sbounds_Attr_Idx]) = TRUE;
   }

   ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Sbounds_Attr_Idx]);

   /* count (= 0) must be static temp */

   tmp_idx = gen_initialized_tmp(CN_INTEGER_ZERO_IDX, line, col);
   line_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, line);
   list_idx = gen_il(7, TRUE, line, col,
                     CN_Tbl_Idx, put_file_name_in_cn(line),     /* file name */
                     CN_Tbl_Idx, line_idx,                      /* line */
                     CN_Tbl_Idx, put_c_str_in_cn(var),		/* var name */
                     OPND_FLD((*size_opnd)), OPND_IDX((*size_opnd)),
                     OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)),
                     OPND_FLD((*subln_opnd)), OPND_IDX((*subln_opnd)),
                     AT_Tbl_Idx, tmp_idx);                      /* count */

   call_idx = gen_ir(AT_Tbl_Idx, glb_tbl_idx[Sbounds_Attr_Idx],
                 Call_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                     IL_Tbl_Idx, list_idx);

   gen_sh(Before, Call_Stmt, line, col,
          FALSE, FALSE, TRUE);
   curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
   SH_IR_IDX(curr_stmt_sh_idx) = call_idx;
   SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

   gen_opnd(&opnd, call_idx, IR_Tbl_Idx, line, col);

   save_xref_state = xref_state;
   xref_state      = CIF_No_Usage_Rec;
   save_expr_mode  = expr_mode;
   expr_mode       = Regular_Expr;

   exp_desc        = init_exp_desc;
   call_list_semantics(&opnd, &exp_desc, FALSE);
   xref_state = save_xref_state;
   expr_mode  = save_expr_mode;

#ifdef KEY /* Bug 8502 */
   int if_sh_idx =
#endif /* KEY Bug 8502 */
   gen_if_stmt(&cond_opnd,
               SH_NEXT_IDX(start_sh_idx),
               SH_PREV_IDX(end_sh_idx),
               NULL_IDX,
               NULL_IDX,
               line,
               col);
#ifdef KEY /* Bug 8502 */
   isolate_if_predicate(if_sh_idx);
#endif /* KEY Bug 8502 */

   curr_stmt_sh_idx = save_curr_stmt_sh_idx;

   TRACE (Func_Exit, "gen_sbounds_check_call", NULL);

   return;

}  /* gen_sbounds_check_call */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      generate the call to the NULL pointer checking lib routine (which     *|
|*      issues the message). When support exists for a ptr_chk_opr, this      *|
|*      routine will generate that.                                           *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

static void gen_ptr_chk_call(char 	*var, 
                             int	dv_desc,
                             opnd_type	*dv_opnd,
                             int 	line, 
                             int 	col)

{
   int                  call_idx;
   opnd_type            cond_opnd;
   int			dv_idx;
   int                  end_sh_idx;
   int                  eq_idx;
   expr_arg_type        exp_desc;
   int                  ir_idx;
   int			line_idx;
   int                  list_idx;
   opnd_type            opnd;
   int                  save_curr_stmt_sh_idx;
   expr_mode_type       save_expr_mode;
   cif_usage_code_type  save_xref_state;
   int                  start_sh_idx;
   int                  tmp_idx;


   TRACE (Func_Entry, "gen_ptr_chk_call", NULL);

   save_curr_stmt_sh_idx = curr_stmt_sh_idx;

   /* save the bounding stmts for the gen_if_stmt call */

   start_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
   end_sh_idx = curr_stmt_sh_idx;

   /* generate the condition. */

   ir_idx = gen_ir(OPND_FLD((*dv_opnd)), OPND_IDX((*dv_opnd)),
               Dv_Access_Assoc, CG_INTEGER_DEFAULT_TYPE, line, col,
                   NO_Tbl_Idx, NULL_IDX);

   eq_idx = gen_ir(IR_Tbl_Idx, ir_idx,
               Eq_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                   CN_Tbl_Idx, CN_INTEGER_ZERO_IDX);

   gen_opnd(&cond_opnd, eq_idx, IR_Tbl_Idx, line, col);

   if (glb_tbl_idx[Ptr_Chk_Attr_Idx] == NULL_IDX) {
      glb_tbl_idx[Ptr_Chk_Attr_Idx] = create_lib_entry_attr(
                                                   PTR_CHK_LIB_ENTRY,
                                                   PTR_CHK_NAME_LEN,
                                                   line,
                                                   col);
	ATP_PURE(glb_tbl_idx[Ptr_Chk_Attr_Idx]) = TRUE;
   }

   ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Ptr_Chk_Attr_Idx]);

   /* count (= 0) must be static temp */

   tmp_idx = gen_initialized_tmp(CN_INTEGER_ZERO_IDX, line, col);
   line_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, line);
   dv_idx  = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, dv_desc);

   list_idx = gen_il(5, TRUE, line, col,
                     CN_Tbl_Idx, put_file_name_in_cn(line),     /* file name */
                     CN_Tbl_Idx, line_idx,                      /* line */
                     CN_Tbl_Idx, put_c_str_in_cn(var),          /* var name */
                     CN_Tbl_Idx, dv_idx,                        /* dv_desc */
                     AT_Tbl_Idx, tmp_idx);                      /* count */

   call_idx = gen_ir(AT_Tbl_Idx, glb_tbl_idx[Ptr_Chk_Attr_Idx],
                 Call_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                     IL_Tbl_Idx, list_idx);

   gen_sh(Before, Call_Stmt, line, col,
          FALSE, FALSE, TRUE);
   curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
   SH_IR_IDX(curr_stmt_sh_idx) = call_idx;
   SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

   gen_opnd(&opnd, call_idx, IR_Tbl_Idx, line, col);

   save_xref_state = xref_state;
   xref_state      = CIF_No_Usage_Rec;
   save_expr_mode  = expr_mode;
   expr_mode       = Regular_Expr;

   exp_desc        = init_exp_desc;
   call_list_semantics(&opnd, &exp_desc, FALSE);
   xref_state = save_xref_state;
   expr_mode  = save_expr_mode;

   gen_if_stmt(&cond_opnd,
               SH_NEXT_IDX(start_sh_idx),
               SH_PREV_IDX(end_sh_idx),
               NULL_IDX,
               NULL_IDX,
               line,
               col);

   curr_stmt_sh_idx = save_curr_stmt_sh_idx;

   TRACE (Func_Exit, "gen_ptr_chk_call", NULL);

   return;

}  /* gen_ptr_chk_call */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	generate a static compiler temp with the type of the given contant    *|
|*      and initialize it to the constant.                                    *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

int gen_initialized_tmp(int	cn_idx,
                        int	line,
                        int	col)

{
   int	asg_idx;
   int	list_idx;
   int	tmp_idx;

   TRACE (Func_Entry, "gen_initialized_tmp", NULL);

   tmp_idx                    = gen_compiler_tmp(line,col, Shared, TRUE);
   ATD_TYPE_IDX(tmp_idx)      = CN_TYPE_IDX(cn_idx);

   ATD_SAVED(tmp_idx)         = TRUE;
   ATD_DATA_INIT(tmp_idx)     = TRUE;
   ATD_STOR_BLK_IDX(tmp_idx)  = SCP_SB_STATIC_INIT_IDX(curr_scp_idx);
   ATD_FLD(tmp_idx)           = CN_Tbl_Idx;
   ATD_TMP_IDX(tmp_idx)       = cn_idx;
   AT_SEMANTICS_DONE(tmp_idx) = TRUE;

   /* create data init stmt */
   NTR_IR_TBL(asg_idx);
   IR_OPR(asg_idx) = Init_Opr;
   IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE;
   IR_LINE_NUM(asg_idx) = line;
   IR_COL_NUM(asg_idx)  = col;
   IR_LINE_NUM_L(asg_idx) = line;
   IR_COL_NUM_L(asg_idx)  = col;
   IR_FLD_L(asg_idx)    = AT_Tbl_Idx;
   IR_IDX_L(asg_idx)    = tmp_idx;

   NTR_IR_LIST_TBL(list_idx);
   IR_FLD_R(asg_idx) = IL_Tbl_Idx;
   IR_IDX_R(asg_idx) = list_idx;
   IR_LIST_CNT_R(asg_idx) = 3;

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = cn_idx;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
   list_idx = IL_NEXT_LIST_IDX(list_idx);

   IL_FLD(list_idx) = CN_Tbl_Idx;
   IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
   IL_LINE_NUM(list_idx) = line;
   IL_COL_NUM(list_idx)  = col;

   gen_sh(Before, Assignment_Stmt, line, col,
          FALSE, FALSE, TRUE);
   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   TRACE (Func_Exit, "gen_initialized_tmp", NULL);

   return(tmp_idx);

}  /* gen_initialized_tmp */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

static int put_file_name_in_cn(int      line)

{
   int          cn_idx;
   int          idx;
   char         name[MAX_FILE_NAME_SIZE];


   TRACE (Func_Entry, "put_file_name_in_cn", NULL);

   /*******************************************************\
   |* THIS ROUTINE IS ONLY FOR RUNTIME CHECKING CALLS !!! *|
   \*******************************************************/

   strcpy(name, global_to_local_file(line));

   for (idx = strlen(name) - 1; idx >= 0; idx--) {
      if (name[idx] == '/')
         break;
   }

   idx++;

   cn_idx = put_c_str_in_cn(&(name[idx]));

   TRACE (Func_Exit, "put_file_name_in_cn", NULL);

   return(cn_idx);

}  /* put_file_name_in_cn */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

static int put_c_str_in_cn(char *ch_ptr)

{
   int          cn_idx;
   int          i;
   long		length;
   long_type    the_constant[(MAX_FILE_NAME_SIZE + TARGET_CHARS_PER_WORD - 1)/
                             TARGET_CHARS_PER_WORD];
   int          type_idx;

   TRACE (Func_Entry, "put_c_str_in_cn", NULL);

   /*******************************************************\
   |* THIS ROUTINE IS ONLY FOR RUNTIME CHECKING CALLS !!! *|
   \*******************************************************/

   for (i = 0; i < (MAX_FILE_NAME_SIZE + TARGET_CHARS_PER_WORD - 1)/
                             TARGET_CHARS_PER_WORD; i++) {
      the_constant[i] = 0;
   }

   length = (long) strlen(ch_ptr);

   /* add one to length for the null byte */
   length++;

   strcpy((char *)the_constant, ch_ptr);

   if (two_word_fcd) {
      CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
      TYP_TYPE(TYP_WORK_IDX)       = Typeless;
      TYP_BIT_LEN(TYP_WORK_IDX)    = WORD_ALIGNED_BIT_LENGTH(length * CHAR_BIT);
      type_idx                     = ntr_type_tbl();
   }
   else {
      CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
      TYP_TYPE(TYP_WORK_IDX)    = Character;
      TYP_LINEAR(TYP_WORK_IDX)  = CHARACTER_DEFAULT_TYPE;
      TYP_DESC(TYP_WORK_IDX)    = Default_Typed;
      TYP_CHAR_CLASS(TYP_WORK_IDX)= Const_Len_Char;
      TYP_FLD(TYP_WORK_IDX)     = CN_Tbl_Idx;
      TYP_IDX(TYP_WORK_IDX)     = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, length);
      type_idx                  = ntr_type_tbl();
   }

   cn_idx = ntr_const_tbl(type_idx,
                          TRUE,
                          the_constant);

   TRACE (Func_Exit, "put_c_str_in_cn", NULL);

   return(cn_idx);

}  /* put_c_str_in_cn */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void gen_internal_call_stmt(char 		*name,
			    opnd_type		*opnd,
			    sh_position_type	position)

{

   int		call_idx;
   int		list_idx;
   int		loc_idx;
   int		lib_idx;

   TRACE (Func_Entry, "gen_internal_call_stmt", NULL);

   lib_idx = create_lib_entry_attr(name,
                                   strlen(name),
                                   stmt_start_line,
                                   stmt_start_col);

   ADD_ATTR_TO_LOCAL_LIST(lib_idx);

   NTR_IR_TBL(call_idx);
   IR_OPR(call_idx) = Call_Opr;
   IR_TYPE_IDX(call_idx) = CG_INTEGER_DEFAULT_TYPE;
   IR_LINE_NUM(call_idx) = stmt_start_line;
   IR_COL_NUM(call_idx) = stmt_start_col;
   IR_FLD_L(call_idx) = AT_Tbl_Idx;
   IR_IDX_L(call_idx) = lib_idx;
   IR_LINE_NUM_L(call_idx) = stmt_start_line;
   IR_COL_NUM_L(call_idx) = stmt_start_col;

   NTR_IR_LIST_TBL(list_idx);
   IR_FLD_R(call_idx) = IL_Tbl_Idx;
   IR_IDX_R(call_idx) = list_idx;
   IR_LIST_CNT_R(call_idx) = 1;

   NTR_IR_TBL(loc_idx);

   if (OPND_FLD((*opnd)) == CN_Tbl_Idx) {
      IR_OPR(loc_idx) = Const_Tmp_Loc_Opr;
      IR_TYPE_IDX(loc_idx) = CN_TYPE_IDX(OPND_IDX((*opnd)));
   }
   else {
      IR_OPR(loc_idx) = Aloc_Opr;
      IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
   }

   IR_LINE_NUM(loc_idx) = stmt_start_line;
   IR_COL_NUM(loc_idx)  = stmt_start_col;
   IL_FLD(list_idx) = IR_Tbl_Idx;
   IL_IDX(list_idx) = loc_idx;

   COPY_OPND(IR_OPND_L(loc_idx), (*opnd));

   gen_sh(position, Call_Stmt, stmt_start_line,
           stmt_start_col, FALSE, FALSE, TRUE);

   if (position == Before) {
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = call_idx;
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
   }
   else {
      SH_IR_IDX(curr_stmt_sh_idx)     = call_idx;
      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
   }

   TRACE (Func_Exit, "gen_internal_call_stmt", NULL);

   return;

}  /* gen_internal_call_stmt */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void gen_lb_array_ref(opnd_type		*result_opnd,
                      int		attr_idx)

{
   int		bd_idx;
   int		i;
   int		list_idx;
   int		sub_idx;

   TRACE (Func_Entry, "gen_lb_array_ref", NULL);

   bd_idx = ATD_ARRAY_IDX(attr_idx);

   NTR_IR_TBL(sub_idx);
   IR_OPR(sub_idx) = Subscript_Opr;
   IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(attr_idx);
   IR_LINE_NUM(sub_idx) = stmt_start_line;
   IR_COL_NUM(sub_idx) = stmt_start_col;
   IR_FLD_L(sub_idx) = AT_Tbl_Idx;
   IR_IDX_L(sub_idx) = attr_idx;
   IR_LINE_NUM_L(sub_idx) = stmt_start_line;
   IR_COL_NUM_L(sub_idx) = stmt_start_col;

   NTR_IR_LIST_TBL(list_idx);
   IR_FLD_R(sub_idx) = IL_Tbl_Idx;
   IR_LIST_CNT_R(sub_idx) = BD_RANK(bd_idx);
   IR_IDX_R(sub_idx) = list_idx;

   IL_FLD(list_idx) = BD_LB_FLD(bd_idx, 1);
   IL_IDX(list_idx) = BD_LB_IDX(bd_idx, 1);
   IL_LINE_NUM(list_idx) = stmt_start_line;
   IL_COL_NUM(list_idx)  = stmt_start_col;

   for (i = 2; i <= BD_RANK(bd_idx); i++) {
      NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
      IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
      list_idx = IL_NEXT_LIST_IDX(list_idx);

      IL_FLD(list_idx) = BD_LB_FLD(bd_idx, i);
      IL_IDX(list_idx) = BD_LB_IDX(bd_idx, i);
      IL_LINE_NUM(list_idx) = stmt_start_line;
      IL_COL_NUM(list_idx)  = stmt_start_col;
   }

   OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
   OPND_IDX((*result_opnd)) = sub_idx;

   TRACE (Func_Exit, "gen_lb_array_ref", NULL);

   return;

}  /* gen_lb_array_ref */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void set_up_exp_desc(opnd_type          *top_opnd,
                     expr_arg_type      *exp_desc)

{
   int          attr_idx;
   int          col;
   int          line;

   TRACE (Func_Entry, "set_up_exp_desc", NULL);

   (*exp_desc) = init_exp_desc;

   find_opnd_line_and_column(top_opnd, &line, &col);

   switch (OPND_FLD((*top_opnd))) {
      case AT_Tbl_Idx:
         attr_idx = OPND_IDX((*top_opnd));

         if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
            exp_desc->type_idx = ATD_TYPE_IDX(attr_idx);
            exp_desc->type = TYP_TYPE(exp_desc->type_idx);
            exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
         }
# ifdef _DEBUG
         else {
            PRINTMSG(line, 626, Internal, col,
                     "Data_Obj", "set_up_exp_desc");
         }
# endif
         break;

      case IR_Tbl_Idx:
         exp_desc->type_idx = IR_TYPE_IDX(OPND_IDX((*top_opnd)));
         exp_desc->type = TYP_TYPE(exp_desc->type_idx);
         exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
         exp_desc->rank = IR_RANK(OPND_IDX((*top_opnd)));
         break;

      case CN_Tbl_Idx:
         exp_desc->type_idx = CN_TYPE_IDX(OPND_IDX((*top_opnd)));
         exp_desc->type = TYP_TYPE(exp_desc->type_idx);
         exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
         break;

      default:
# ifdef _DEBUG
         PRINTMSG(line, 626, Internal, col,
                  "AT_Tbl_Idx, IR_Tbl_Idx, or CN_Tbl_Idx",
                  "set_up_exp_desc");
# endif
         break;
   }

   TRACE (Func_Exit, "set_up_exp_desc", NULL);

   return;

}  /* set_up_exp_desc */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Swap the dimensions for certain array bounds and references for the   *|
|*      current scope.                                                        *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void dim_reshape_pass_driver (void)

{
   int          al_idx;
   int          attr_idx;
   opnd_type    opnd;
   int          save_curr_stmt_sh_idx;


   TRACE (Func_Entry, "dim_reshape_pass_driver", NULL);

   save_curr_stmt_sh_idx = curr_stmt_sh_idx;

   /* first, create new bounds table entries for reshape candidates */

   al_idx = SCP_RESHAPE_ARRAY_LIST(curr_scp_idx);

   while (al_idx) {
      attr_idx = AL_ATTR_IDX(al_idx);

# ifdef _DEBUG
      if (AT_OBJ_CLASS(attr_idx) != Data_Obj ||
          ! ATD_RESHAPE_ARRAY_OPT(attr_idx)) {

         PRINTMSG(1, 626, Internal, 1,
                  "ATD_RESHAPE_ARRAY_OPT flag", "dim_reshape_pass_driver");
      }

      if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX ||
          ATD_RESHAPE_ARRAY_IDX(attr_idx) == NULL_IDX) {
         PRINTMSG(1, 626, Internal, 1,
                  "ATD_RESHAPE_ARRAY_IDX", "dim_reshape_pass_driver");
      }
# endif

      ATD_ARRAY_IDX(attr_idx) = ATD_RESHAPE_ARRAY_IDX(attr_idx);
      al_idx = AL_NEXT_IDX(al_idx);
   }

   /* second, traverse the ir to reshape reference dimensions */

   curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx);

   while (curr_stmt_sh_idx != NULL_IDX) {

      if (SH_IR_IDX(curr_stmt_sh_idx) != NULL_IDX) {
         OPND_FLD(opnd) = IR_Tbl_Idx;
         OPND_IDX(opnd) = SH_IR_IDX(curr_stmt_sh_idx);

         reshape_reference_subscripts(&opnd);

         SH_IR_IDX(curr_stmt_sh_idx) = OPND_IDX(opnd);
      }

      curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
   }

   curr_stmt_sh_idx = save_curr_stmt_sh_idx;

   PRINT_IR_TBL4;

   TRACE (Func_Exit, "dim_reshape_pass_driver", NULL);

   return;

}  /* dim_reshape_pass_driver */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      <description>                                                         *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

static void reshape_reference_subscripts(opnd_type *result_opnd)

{
   int                  attr_idx;
   int                  col;
   int                  ir_idx;
   int                  line;
   int                  head;
   int                  list_idx;
   opnd_type            opnd;


   TRACE (Func_Entry, "reshape_reference_subscripts", NULL);

   switch (OPND_FLD((*result_opnd))) {
   case IR_Tbl_Idx:
      ir_idx = OPND_IDX((*result_opnd));

      COPY_OPND(opnd, IR_OPND_L(ir_idx));
      reshape_reference_subscripts(&opnd);
      COPY_OPND(IR_OPND_L(ir_idx), opnd);

      COPY_OPND(opnd, IR_OPND_R(ir_idx));
      reshape_reference_subscripts(&opnd);
      COPY_OPND(IR_OPND_R(ir_idx), opnd);

      if (IR_OPR(ir_idx) == Subscript_Opr ||
          IR_OPR(ir_idx) == Whole_Subscript_Opr ||
          IR_OPR(ir_idx) == Section_Subscript_Opr) {

         COPY_OPND(opnd, IR_OPND_L(ir_idx));
         attr_idx = find_base_attr(&opnd, &line, &col);

         if (ATD_RESHAPE_ARRAY_OPT(attr_idx)) {
            gen_opnd(&opnd, ir_idx, IR_Tbl_Idx, IR_LINE_NUM(ir_idx),
                                                IR_COL_NUM(ir_idx));
            copy_subtree(&opnd, result_opnd, 0, 0);
            ir_idx = OPND_IDX((*result_opnd));

            list_idx = IR_IDX_R(ir_idx);
            head = list_idx;

            while (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) {
               list_idx = IL_NEXT_LIST_IDX(list_idx);
            }
            IR_IDX_R(ir_idx) = list_idx;
            IL_NEXT_LIST_IDX(IL_PREV_LIST_IDX(list_idx)) = NULL_IDX;
            IL_PREV_LIST_IDX(list_idx) = NULL_IDX;
            IL_NEXT_LIST_IDX(list_idx) = head;
            IL_PREV_LIST_IDX(head) = list_idx;
         }
      }
      break;

   case IL_Tbl_Idx:
      list_idx = OPND_IDX((*result_opnd));

      while (list_idx) {
         COPY_OPND(opnd, IL_OPND(list_idx));
         reshape_reference_subscripts(&opnd);
         COPY_OPND(IL_OPND(list_idx), opnd);

         list_idx = IL_NEXT_LIST_IDX(list_idx);
      }
      break;
   }

   TRACE (Func_Exit, "reshape_reference_subscripts", NULL);

   return;

}  /* reshape_reference_subscripts */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/
boolean check_for_legal_define(opnd_type	*top_opnd)
#ifdef KEY /* Bug 14150 */
{
  return check_for_legal_assignment_define(top_opnd, FALSE);
}

/*
 * top_opnd		Top operand of operation which defines lvalue
 * pointer_assign	True if assignment is "=>" not "=" or other defining
 *			operation
 */
boolean check_for_legal_assignment_define(opnd_type *top_opnd,
  boolean pointer_assign)
#endif /* KEY Bug 14150 */
{
   int		attr_idx;
   int		col;
   int		line;
   boolean	ok = TRUE;
   opnd_type	opnd;

   TRACE (Func_Entry, "check_for_legal_define", NULL);

   COPY_OPND(opnd, (*top_opnd));

   while (OPND_FLD(opnd) == IR_Tbl_Idx) {
      COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
   }

#ifdef KEY /* Bug 5091 */
   if (OPND_FLD(opnd) == AT_Tbl_Idx) {
     attr_idx = OPND_IDX(opnd);
     line = OPND_LINE_NUM(opnd);
     col = OPND_COL_NUM(opnd);
     if (readonly_protected(attr_idx)) {
       PRINTMSG(line, 1702, Error, col, AT_OBJ_NAME_PTR(attr_idx));
     }
   }
#endif /* KEY Bug 5091 */

   if (OPND_FLD(opnd) == AT_Tbl_Idx &&
       AT_OBJ_CLASS(OPND_IDX(opnd)) == Data_Obj) {

      attr_idx = OPND_IDX(opnd);
      line = OPND_LINE_NUM(opnd);
      col = OPND_COL_NUM(opnd);

      if (ATD_LIVE_DO_VAR(attr_idx)) {
         PRINTMSG(line, 48, Error, col);
         ok = FALSE;
      }
      else if (ATD_PURE(attr_idx)) {
         PRINTMSG(line, 1270, Error, col,
                  AT_OBJ_NAME_PTR(attr_idx),
                  ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure":"elemental");
         ok = FALSE;
      }
      else if (ATD_CLASS(attr_idx) == Dummy_Argument   &&
#ifdef KEY /* Bug 14150 */
	       /* "l = expr" is ok, "l => expr" is not, "l%p => expr" is ok */
               ((!ATD_POINTER(attr_idx)) || pointer_assign) &&
#endif /* KEY Bug 14150 */
	       (OPND_FLD(*top_opnd) != IR_Tbl_Idx ||
		IR_OPR(OPND_IDX(*top_opnd)) != Dv_Deref_Opr || !pointer_assign) &&
               ATD_INTENT(attr_idx) == Intent_In) {
         PRINTMSG(line, 890, Error, col,
                  AT_OBJ_NAME_PTR(attr_idx));
         ok = FALSE;
      }
      else if (ATD_FORALL_INDEX(attr_idx)) {
         PRINTMSG(line, 1608, Error, col,
                  AT_OBJ_NAME_PTR(attr_idx));
         ok = FALSE;
      }
      else if (ATD_SYMBOLIC_CONSTANT(attr_idx) &&
               (ATD_CLASS(attr_idx) == Variable ||
                ATD_CLASS(attr_idx) == Constant)) {
         PRINTMSG(line, 1632, Error, col,
                  AT_OBJ_NAME_PTR(attr_idx));
         ok = FALSE;
      }
   }


   TRACE (Func_Exit, "check_for_legal_define", NULL);

   return(ok);

}  /* check_for_legal_define */



/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Check for a dependence in an arbitrary expression.                    *|
|*									      *|
|* Input parameters:							      *|
|*	item	opject which we will search for in exp                        *|
|*      exp     this is the expression that is to be searched                 *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	boolean indicating a dependence was found                             *|
|*									      *|
\******************************************************************************/
void check_dependence(boolean    *dependant,
                      opnd_type  item,
                      opnd_type  exp)

{
   int		attr_idx;
   int		idx;
   int		fld;
   int		line;
   int		col;

static   int		level;
static   boolean	target_found;
static   boolean	pointer_found;
static   boolean	pointer_item;
static   boolean	target_item;

   TRACE (Func_Entry, "check_dependence", NULL);
   level = level + 1;


   attr_idx = find_base_attr(&item, &line, &col);
   if (ATD_POINTER(attr_idx))  pointer_item = TRUE;
   if (ATD_TARGET(attr_idx))  target_item = TRUE;
   if (ATD_CLASS(attr_idx) == CRI__Pointee)  *dependant = TRUE;

   attr_idx = find_left_attr(&item);
   if (ATD_EQUIV(attr_idx))  *dependant = TRUE;

   idx = OPND_IDX(exp);
   fld = OPND_FLD(exp);

   if (idx != NULL_IDX) {

      switch(fld) {
         case IR_Tbl_Idx :
            if (IR_FLD_R(idx) != NO_Tbl_Idx) {
               check_dependence(dependant, item, IR_OPND_R(idx));
            }

            if (IR_FLD_L(idx) != NO_Tbl_Idx) {
               check_dependence(dependant, item, IR_OPND_L(idx));
            }
            break;

         case AT_Tbl_Idx :
            if (AT_OBJ_CLASS(idx) == Data_Obj) {
               if (ATD_TARGET(idx))  target_found = TRUE;
               if (ATD_POINTER(idx))  pointer_found = TRUE;
               if (idx == attr_idx) *dependant = TRUE;
            }
            break;

         case NO_Tbl_Idx :
         case CN_Tbl_Idx :
         case SH_Tbl_Idx :
            break;

         case IL_Tbl_Idx :
            while (idx != NULL_IDX) {
               if (IL_FLD(idx) != NO_Tbl_Idx) {
                  check_dependence(dependant, item, IL_OPND(idx));
               }
               idx = IL_NEXT_LIST_IDX(idx);
            }
            break;
      }
   }


   level = level - 1;
   if (level == 0) {
      if (target_found && pointer_item) *dependant = TRUE;
      if (pointer_found && pointer_item) *dependant = TRUE;
      if (pointer_found && target_item) *dependant = TRUE;
      target_found = FALSE;
      pointer_found = FALSE;
      pointer_item = FALSE;
      target_item = FALSE;
   }

   TRACE (Func_Exit, "check_dependence", NULL);

}  /* check_dependence */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This routine takes an array section (or whole array) reference and    *|
|*      returns an array element reference corresponding to which_one.        *|
|*	the section must be rank 1 and which_one is 1 based.                  *|
|*									      *|
|* Input parameters:							      *|
|*	section_opnd	- the array section                                   *|
|*	which_one	- which element you want (1,2,3,...)                  *|
|*									      *|
|* Output parameters:							      *|
|*	element_opnd	- the resulting element reference tree.               *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void change_section_to_this_element(opnd_type	*section_opnd,
                                    opnd_type	*element_opnd,
                                    int		which_one)

{
   int			col;
   expr_arg_type	exp_desc;
   int			line;
   int			list_idx;
   int			mult_idx;
   opnd_type		opnd1;
   opnd_type		opnd2;
   int			plus_idx;
   int			rank_idx = NULL_IDX;
   cif_usage_code_type	save_xref_state;
   int			start_list_idx;
   int			stride_list_idx;
   int			trip_idx;
   int			unused = NULL_IDX;

   TRACE (Func_Entry, "change_section_to_this_element", NULL);

   find_opnd_line_and_column(section_opnd, &line, &col);

# ifdef _DEBUG
   if (OPND_FLD((*section_opnd)) != IR_Tbl_Idx ||
       IR_RANK(OPND_IDX((*section_opnd))) != 1) {
      PRINTMSG(line, 626, Internal, col,
               "rank 1 array", "change_section_to_this_element");
   }
# endif

   copy_subtree(section_opnd, element_opnd, 0, 0);

   just_find_dope_and_rank(element_opnd, &rank_idx, &unused);

# ifdef _DEBUG
   if (rank_idx == NULL_IDX) {
      PRINTMSG(line, 626, Internal, col,
               "section subscript", "change_section_to_this_element");
   }
# endif

   IR_OPR(rank_idx) = Subscript_Opr;

   list_idx = IR_IDX_R(rank_idx);

   while (list_idx) {
      if (IL_VECTOR_SUBSCRIPT(list_idx)) {
         COPY_OPND(opnd1, IL_OPND(list_idx));
         change_section_to_this_element(&opnd1, &opnd2, which_one);
         COPY_OPND(IL_OPND(list_idx), opnd2);
         break;
      }
      else if (IL_FLD(list_idx) == IR_Tbl_Idx &&
               IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) {

         trip_idx = IL_IDX(list_idx);
         start_list_idx = IR_IDX_L(trip_idx);
         stride_list_idx = IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(start_list_idx));
         line = IR_LINE_NUM(trip_idx);
         col = IR_COL_NUM(trip_idx);

         
         mult_idx = gen_ir(CN_Tbl_Idx, C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
                                                   (which_one - 1)),
                       Mult_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                           IL_FLD(stride_list_idx), IL_IDX(stride_list_idx));

         plus_idx = gen_ir(IL_FLD(start_list_idx), IL_IDX(start_list_idx),
                       Plus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                           IR_Tbl_Idx, mult_idx);

         gen_opnd(&opnd1, plus_idx, IR_Tbl_Idx, line, col);

         exp_desc        = init_exp_desc;
         exp_desc.rank   = 0;
         save_xref_state = xref_state;
         xref_state      = CIF_No_Usage_Rec;
                           expr_semantics(&opnd1, &exp_desc);
         xref_state      = save_xref_state;

         COPY_OPND(IL_OPND(list_idx), opnd1);

         break;
      }

      list_idx = IL_NEXT_LIST_IDX(list_idx);
   }

   COPY_OPND(opnd1, (*element_opnd));

   while (OPND_FLD(opnd1) == IR_Tbl_Idx) {
      IR_RANK(OPND_IDX(opnd1)) = 0;
      COPY_OPND(opnd1, IR_OPND_L(OPND_IDX(opnd1)));
   }
   

   TRACE (Func_Exit, "change_section_to_this_element", NULL);

   return;

}  /* change_section_to_this_element */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

#ifdef KEY /* Bug 8502 */
/* Return sh_idx for "if" statement */
int
#else /* KEY Bug 8502 */
void
#endif /* KEY Bug 8502 */
gen_if_stmt(opnd_type	*cond_opnd,
		 int		true_start_sh_idx,
		 int		true_end_sh_idx,
		 int		false_start_sh_idx,
		 int		false_end_sh_idx,
		 int		line,
		 int		col)

{
   int		else_idx;
   int		endif_idx;
   int		if_idx;
   int		save_curr_stmt_sh_idx;
#ifdef KEY /* Bug 10177 */
   int		type_idx = 0;
#else /* KEY Bug 10177 */
   int		type_idx;
#endif /* KEY Bug 10177 */

# if defined(_HIGH_LEVEL_IF_FORM)
   int		if_sh_idx;
   int		parent_sh_idx;
# else
   int		label1_idx;
   int		label2_idx;
# endif


   TRACE (Func_Entry, "gen_if_stmt", NULL);

# ifdef _DEBUG
   if (SH_PREV_IDX(true_start_sh_idx) == true_end_sh_idx) {
      PRINTMSG(line, 626, Internal, col,
               "proper true block", "gen_if_stmt");
   }

   if (false_start_sh_idx &&
       SH_PREV_IDX(false_start_sh_idx) != true_end_sh_idx) {
      PRINTMSG(line, 626, Internal, col,
               "proper false block", "gen_if_stmt");
   }

   if (false_start_sh_idx &&
       SH_PREV_IDX(false_start_sh_idx) == false_end_sh_idx) {
      PRINTMSG(line, 626, Internal, col,
               "proper false block", "gen_if_stmt");
   }
# endif

   save_curr_stmt_sh_idx = curr_stmt_sh_idx;

   switch (OPND_FLD((*cond_opnd))) {
   case AT_Tbl_Idx:
      type_idx = ATD_TYPE_IDX(OPND_IDX((*cond_opnd)));
      break;

   case IR_Tbl_Idx:
      type_idx = IR_TYPE_IDX(OPND_IDX((*cond_opnd)));
      break;

   case CN_Tbl_Idx:
      type_idx = CN_TYPE_IDX(OPND_IDX((*cond_opnd)));
      break;

   default:
# ifdef _DEBUG
      PRINTMSG(line, 626, Internal, col,
               "valid logical condition", "gen_if_stmt");
# endif
      break;
   }

   curr_stmt_sh_idx = true_start_sh_idx;

# if defined(_HIGH_LEVEL_IF_FORM)

   if_idx = gen_ir(OPND_FLD((*cond_opnd)), OPND_IDX((*cond_opnd)),
              If_Opr, type_idx, line, col,
                   NO_Tbl_Idx, NULL_IDX);

   gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = if_idx;

   if_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);

   curr_stmt_sh_idx = true_end_sh_idx;

   parent_sh_idx = if_sh_idx;

   if (false_start_sh_idx) {

      curr_stmt_sh_idx = false_start_sh_idx;

      else_idx = gen_ir(OPND_FLD((*cond_opnd)), OPND_IDX((*cond_opnd)),
                 Else_Opr, type_idx, line, col,
                      NO_Tbl_Idx, NULL_IDX);

      gen_sh(Before, Else_Stmt, line, col, FALSE, FALSE, TRUE);
      SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
      SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = else_idx;
      parent_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);

      curr_stmt_sh_idx = false_end_sh_idx;

   }

   endif_idx = gen_ir(SH_Tbl_Idx, if_sh_idx,
                 Endif_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                      NO_Tbl_Idx, NULL_IDX);

   gen_sh(After, End_If_Stmt, line, col, FALSE, FALSE, TRUE);
   SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
   SH_IR_IDX(curr_stmt_sh_idx) = endif_idx;
   SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = parent_sh_idx;

   IR_FLD_R(if_idx) = SH_Tbl_Idx;
   IR_IDX_R(if_idx) = curr_stmt_sh_idx;
   IR_LINE_NUM_R(if_idx) = line;
   IR_COL_NUM_R(if_idx) = col;

# else

   label1_idx = gen_internal_lbl(line);

   if_idx = gen_ir(IR_Tbl_Idx,
                  gen_ir(OPND_FLD((*cond_opnd)),OPND_IDX((*cond_opnd)),
                     Not_Opr, type_idx, line, col,
                         NO_Tbl_Idx, NULL_IDX),
              Br_True_Opr, type_idx, line, col,
                   AT_Tbl_Idx, label1_idx);

   gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = if_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   curr_stmt_sh_idx = true_end_sh_idx;

   endif_idx = gen_ir(AT_Tbl_Idx, label1_idx,
              Label_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                   NO_Tbl_Idx, NULL_IDX);

   gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE);
   SH_IR_IDX(curr_stmt_sh_idx) = endif_idx;
   SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

   AT_DEFINED(label1_idx) = TRUE;
   ATL_DEF_STMT_IDX(label1_idx) = curr_stmt_sh_idx;

   if (false_start_sh_idx) {
      curr_stmt_sh_idx = true_end_sh_idx;

      label2_idx = gen_internal_lbl(line);

      else_idx = gen_ir(NO_Tbl_Idx, NULL_IDX,
                 Br_Uncond_Opr, type_idx, line, col,
                      AT_Tbl_Idx, label2_idx);

      gen_sh(After, Goto_Stmt, line, col, FALSE, FALSE, TRUE);
      SH_IR_IDX(curr_stmt_sh_idx) = else_idx;
      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

      curr_stmt_sh_idx = false_end_sh_idx;

      endif_idx = gen_ir(AT_Tbl_Idx, label2_idx,
                 Label_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                      NO_Tbl_Idx, NULL_IDX);

      gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE);
      SH_IR_IDX(curr_stmt_sh_idx) = endif_idx;
      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;

      AT_DEFINED(label2_idx) = TRUE;
      ATL_DEF_STMT_IDX(label2_idx) = curr_stmt_sh_idx;
   }


# endif


   curr_stmt_sh_idx = save_curr_stmt_sh_idx;

   TRACE (Func_Exit, "gen_if_stmt", NULL);

#ifdef KEY /* Bug 8502 */
   return if_sh_idx;
#else /* KEY Bug 8502 */
   return;
#endif /* KEY Bug 8502 */

}  /* gen_if_stmt */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

#ifdef KEY /* Bug 7969 */
/*
 * sub_idx	IR_Tbl_Idx for {Whole_,Section_,}Subscript_Opr
 * ignore_cdir_bounds	Ignore cdir_switches.bounds (set to make FE check
 *			constant bounds at compile time even in absence of -C
 *			or -ffortran-bounds-check)
 */
boolean	needs_bounds_check(int sub_idx, boolean ignore_cdir_bounds)
#else /* KEY Bug 7969 */
boolean	needs_bounds_check(int	sub_idx)
#endif /* KEY Bug 7969 */

{
   int		base_attr;
   int		bd_idx;
   boolean	bound_chk;
   int		col;
   int		left_attr;
   int		line;

   TRACE (Func_Entry, "needs_bounds_check", NULL);

# ifdef _DEBUG
   if (IR_OPR(sub_idx) != Whole_Subscript_Opr &&
       IR_OPR(sub_idx) != Section_Subscript_Opr &&
       IR_OPR(sub_idx) != Subscript_Opr) {

      PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
               "Subscript_Opr", "needs_bounds_check");
   }
# endif

   base_attr = find_base_attr(&IR_OPND_L(sub_idx), &line, &col);
   left_attr = find_left_attr(&IR_OPND_L(sub_idx));
   bd_idx = ATD_ARRAY_IDX(base_attr);

   bound_chk = (cdir_switches.bounds ||
#ifdef KEY /* Bug 7969 */
		ignore_cdir_bounds ||
#endif /* KEY Bug 7969 */
                ATD_BOUNDS_CHECK(left_attr)) &&
               !ATD_NOBOUNDS_CHECK(left_attr);

   bound_chk &= ! (IR_WHOLE_ARRAY(sub_idx));

   if (IR_BOUNDS_DONE(sub_idx) ||
       IR_OPR(sub_idx) == Whole_Subscript_Opr ||
       ATD_CLASS(base_attr) == Compiler_Tmp) {
      bound_chk = FALSE;
   }

   if (BD_RANK(bd_idx) == 1 &&
       BD_ARRAY_CLASS(bd_idx) == Explicit_Shape &&
       BD_LB_FLD(bd_idx,1) == CN_Tbl_Idx &&
       compare_cn_and_value(BD_LB_IDX(bd_idx,1), 1, Eq_Opr) &&
       BD_UB_FLD(bd_idx,1) == CN_Tbl_Idx &&
       compare_cn_and_value(BD_UB_IDX(bd_idx,1), 1, Eq_Opr)) {

      bound_chk = FALSE;
   }
   

   TRACE (Func_Exit, "needs_bounds_check", NULL);

   return(bound_chk);

}  /* needs_bounds_check */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void gen_rbounds_condition(opnd_type	*cond_opnd,
                           opnd_type	*start_opnd,
                           opnd_type	*end_opnd,
                           opnd_type	*inc_opnd,
                           opnd_type	*lb_opnd,
                           opnd_type	*ub_opnd,
                           int		line,
                           int		col)

{
   int			and_idx;
   int                  div_idx;
   expr_arg_type        exp_desc;
   int                  gt_idx;
   int                  lt_idx;
   int                  minus_idx;
   int                  mult_idx;
   int                  or_idx1;
   int                  or_idx2;
   int                  or_idx3;
   opnd_type            opnd;
   int                  plus_idx;
   expr_mode_type       save_expr_mode;
   cif_usage_code_type  save_xref_state;
   opnd_type		xt_opnd;


   TRACE (Func_Entry, "gen_rbounds_condition", NULL);

   /* cond_opnd = ((start < lb .or. start > ub) .or.                 */
   /* (start + (((end - start + inc) / inc) - 1) * inc < lb) .or.    */
   /* (start + (((end - start + inc) / inc) - 1) * inc > ub)) .and.  */
   /* (((end - start + inc) / inc) > 0)                              */

   /* start_opnd < lb */

   lt_idx = gen_ir(OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)),
               Lt_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                   OPND_FLD((*lb_opnd)), OPND_IDX((*lb_opnd)));

   /* start_opnd > ub */

#ifdef KEY /* Bug 7969 */
   /* Skip comparison of upper bound of assumed-size array */
   if (ub_opnd == 0) {
     or_idx1 = lt_idx;
   }
   else {
#endif /* KEY Bug 7969 */
   gt_idx = gen_ir(OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)),
               Gt_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                   OPND_FLD((*ub_opnd)), OPND_IDX((*ub_opnd)));



   or_idx1 = gen_ir(IR_Tbl_Idx, lt_idx,
                Or_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                    IR_Tbl_Idx, gt_idx);
#ifdef KEY /* Bug 7969 */
   }
#endif /* KEY Bug 7969 */


   /* start + (((end - start + inc) / inc) - 1) * inc */

   minus_idx = gen_ir(OPND_FLD((*end_opnd)), OPND_IDX((*end_opnd)),
                  Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                      OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)));

   plus_idx = gen_ir(IR_Tbl_Idx, minus_idx,
                 Plus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                     OPND_FLD((*inc_opnd)), OPND_IDX((*inc_opnd)));

   div_idx = gen_ir(IR_Tbl_Idx, plus_idx,
                Div_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                    OPND_FLD((*inc_opnd)), OPND_IDX((*inc_opnd)));

   gen_opnd(&xt_opnd, div_idx, IR_Tbl_Idx, line, col);
   copy_subtree(&xt_opnd, &xt_opnd, 0, 0);

   minus_idx = gen_ir(IR_Tbl_Idx, div_idx,
                  Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                      CN_Tbl_Idx, CN_INTEGER_ONE_IDX);

   mult_idx = gen_ir(IR_Tbl_Idx, minus_idx,
                 Mult_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                     OPND_FLD((*inc_opnd)), OPND_IDX((*inc_opnd)));

   plus_idx = gen_ir(OPND_FLD((*start_opnd)), OPND_IDX((*start_opnd)),
                 Plus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
                     IR_Tbl_Idx, mult_idx);

   lt_idx = gen_ir(IR_Tbl_Idx, plus_idx,
               Lt_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                   OPND_FLD((*lb_opnd)), OPND_IDX((*lb_opnd)));

   gen_opnd(&opnd, plus_idx, IR_Tbl_Idx, line, col);

   copy_subtree(&opnd, &opnd, 0, 0);

#ifdef KEY /* Bug 7969 */
   /* Skip comparison of upper bound of assumed-size array */
   if (ub_opnd == 0) {
     or_idx2 = lt_idx;
   }
   else {
#endif /* KEY Bug 7969 */
   gt_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
               Gt_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                   OPND_FLD((*ub_opnd)), OPND_IDX((*ub_opnd)));



   or_idx2 = gen_ir(IR_Tbl_Idx, lt_idx,
                Or_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                    IR_Tbl_Idx, gt_idx);
#ifdef KEY /* Bug 7969 */
   }
#endif /* KEY Bug 7969 */


   or_idx3 = gen_ir(IR_Tbl_Idx, or_idx1,
                Or_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                    IR_Tbl_Idx, or_idx2);

   gt_idx = gen_ir(OPND_FLD(xt_opnd), OPND_IDX(xt_opnd),
               Gt_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                   CN_Tbl_Idx, CN_INTEGER_ZERO_IDX);

   and_idx = gen_ir(IR_Tbl_Idx, or_idx3,
                And_Opr, LOGICAL_DEFAULT_TYPE, line, col,
                    IR_Tbl_Idx, gt_idx);

   gen_opnd(cond_opnd, and_idx, IR_Tbl_Idx, line, col);

   save_xref_state = xref_state;
   xref_state      = CIF_No_Usage_Rec;
   save_expr_mode  = expr_mode;
   expr_mode       = Regular_Expr;

   exp_desc        = init_exp_desc;
                      expr_semantics(cond_opnd, &exp_desc);
   xref_state = save_xref_state;
   expr_mode  = save_expr_mode;

   TRACE (Func_Exit, "gen_rbounds_condition", NULL);

   return;

}  /* gen_rbounds_condition */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void scan_for_ptr_chk(opnd_type	*top_opnd)

{
   opnd_type	dv_opnd;
   int		ir_idx;
   int		list_idx;
   opnd_type	opnd;

   TRACE (Func_Entry, "scan_for_ptr_chk", NULL);

   switch (OPND_FLD((*top_opnd))) {
   case IR_Tbl_Idx:
      ir_idx = OPND_IDX((*top_opnd));

      if (IR_OPR(ir_idx) == Dv_Deref_Opr) {
         COPY_OPND(dv_opnd, IR_OPND_L(ir_idx));
         gen_runtime_ptr_chk(&dv_opnd);
      }

      COPY_OPND(opnd, IR_OPND_L(ir_idx));
      scan_for_ptr_chk(&opnd);

      COPY_OPND(opnd, IR_OPND_R(ir_idx));
      scan_for_ptr_chk(&opnd);
      break;

   case IL_Tbl_Idx:
      list_idx = OPND_IDX((*top_opnd));

      while (list_idx) {
         COPY_OPND(opnd, IL_OPND(list_idx));
         scan_for_ptr_chk(&opnd);
         list_idx = IL_NEXT_LIST_IDX(list_idx);
      }
      break;
   }

   TRACE (Func_Exit, "scan_for_ptr_chk", NULL);

   return;

}  /* scan_for_ptr_chk */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void runtime_ptr_chk_driver(void)

{
   opnd_type	opnd;
   int		save_curr_stmt_sh_idx;

   TRACE (Func_Entry, "runtime_ptr_chk_driver", NULL);

   save_curr_stmt_sh_idx = curr_stmt_sh_idx;

   curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx);

   while (curr_stmt_sh_idx != NULL_IDX) {

      if (SH_IR_IDX(curr_stmt_sh_idx) != NULL_IDX) {
         gen_opnd(&opnd, SH_IR_IDX(curr_stmt_sh_idx), IR_Tbl_Idx,
                  SH_GLB_LINE(curr_stmt_sh_idx), SH_COL_NUM(curr_stmt_sh_idx));
         scan_for_ptr_chk(&opnd);
      }

      curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
   }

   PRINT_IR_TBL4;

   curr_stmt_sh_idx = save_curr_stmt_sh_idx;

   TRACE (Func_Exit, "runtime_ptr_chk_driver", NULL);

   return;

}  /* runtime_ptr_chk_driver */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void gen_copyin_bounds_stmt(int	attr_idx)

{
# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
   int		col;
   int		ir_idx;
   int		line;

   TRACE (Func_Entry, "gen_copyin_bounds_stmt", NULL);

   line = AT_DEF_LINE(attr_idx);
   col = AT_DEF_COLUMN(attr_idx);

   ir_idx = gen_ir(AT_Tbl_Idx, attr_idx,
               Copyin_Bound_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                   NO_Tbl_Idx, NULL_IDX);

   gen_sh(Before, Directive_Stmt, line, col, FALSE, FALSE, TRUE);
   SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
   SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;

   TRACE (Func_Exit, "gen_copyin_bounds_stmt", NULL);

# endif
   return;

}  /* gen_copyin_bounds_stmt */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

void gen_dv_access_low_bound(opnd_type	*result_opnd,
                             opnd_type	*dv_opnd,
                             int	 dim)

{
   int			attr_idx;
   int			bd_idx;
   int			col;
   expr_arg_type	exp_desc;
   int			ir_idx;
   int			line;
   cif_usage_code_type	save_xref_state;


   TRACE (Func_Entry, "gen_dv_access_low_bound", NULL);

   attr_idx = find_base_attr(dv_opnd, &line, &col);

# ifdef _DEBUG
   if (! ATD_IM_A_DOPE(attr_idx)) {
      PRINTMSG(line, 626, Internal, col,
               "dope vector" , "gen_dv_low_bound");
   }
# endif

   bd_idx = ATD_ARRAY_IDX(attr_idx);

   if (bd_idx &&
       BD_ARRAY_CLASS(bd_idx) == Assumed_Shape) {

      gen_opnd(result_opnd, BD_LB_IDX(bd_idx,dim), BD_LB_FLD(bd_idx,dim),
               line, col);

      if (variable_size_func_expr &&
          OPND_FLD((*result_opnd)) == AT_Tbl_Idx &&
          ATD_CLASS(OPND_IDX((*result_opnd))) == Compiler_Tmp &&
          ATD_FLD(OPND_IDX((*result_opnd))) == IR_Tbl_Idx &&
          IR_OPR(ATD_TMP_IDX(OPND_IDX((*result_opnd)))) == Asg_Opr) {

         while (OPND_FLD((*result_opnd)) == AT_Tbl_Idx &&
                ATD_CLASS(OPND_IDX((*result_opnd))) == Compiler_Tmp &&
                ATD_FLD(OPND_IDX((*result_opnd))) == IR_Tbl_Idx &&
                IR_OPR(ATD_TMP_IDX(OPND_IDX((*result_opnd)))) == Asg_Opr) {

            COPY_OPND((*result_opnd), 
                      IR_OPND_R(ATD_TMP_IDX(OPND_IDX((*result_opnd)))));
         }

         exp_desc.rank = 0;
         
         save_xref_state = xref_state;
         xref_state      = CIF_No_Usage_Rec;
                           expr_semantics(result_opnd, &exp_desc);
         xref_state      = save_xref_state;
      }
   }
   else {
      ir_idx = gen_ir(OPND_FLD((*dv_opnd)), OPND_IDX((*dv_opnd)),
                  Dv_Access_Low_Bound, SA_INTEGER_DEFAULT_TYPE, line, col,
                      NO_Tbl_Idx, NULL_IDX);
      IR_DV_DIM(ir_idx) = dim;

      gen_opnd(result_opnd, ir_idx, IR_Tbl_Idx, line, col);
   }

   TRACE (Func_Exit, "gen_dv_access_low_bound", NULL);

   return;

}  /* gen_dv_access_low_bound */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	<description>							      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

long64	sm_unit_in_bits(int	type_idx)

{
   long64	bits;


   TRACE (Func_Entry, "sm_unit_in_bits", NULL);

# if defined(_SM_UNIT_IS_ELEMENT)

   switch (TYP_TYPE(type_idx)) {
   case Typeless:
      bits = TYP_BIT_LEN(type_idx);
      break;

   case Integer:
   case Logical:
   case CRI_Ptr:
   case CRI_Ch_Ptr:
   case Real:
   case Complex:
      bits = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
      break;

   case Character:

# ifdef _DEBUG
      if (TYP_FLD(type_idx) != CN_Tbl_Idx) {
         PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
                  "constant length character", "sm_unit_in_bits");
      }
# endif
      bits = CN_INT_TO_C(TYP_IDX(type_idx)) * 8;
      break;

   case Structure:
# ifdef _DEBUG
      if (ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)) != CN_Tbl_Idx) {
         PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col,
                  "constant length structure", "sm_unit_in_bits");
      }
# endif
      bits = CN_INT_TO_C(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)));
      break;
   }

# else

   bits = stride_mult_unit_in_bits[TYP_LINEAR(type_idx)];

# endif

   TRACE (Func_Exit, "sm_unit_in_bits", NULL);

   return(bits);

}  /* sm_unit_in_bits */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Generate a data init or assignment stmt to initialize a temp to a     *|
|*      constant value. If it is an assignment, generate it a every entry.    *|
|*                                                                            *|
|* Input parameters:                                                          *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Output parameters:                                                         *|
|*      NONE                                                                  *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NOTHING                                                               *|
|*                                                                            *|
\******************************************************************************/

void gen_temp_init(int  attr_idx,
                   int  cn_idx)

{
   int		col;
   int		entry_attr_idx;
   int		entry_list_idx;
   int		entry_sh_idx;
   int		ir_idx;
   int		line;
   opnd_type	opnd;
   int		sh_idx;
   int		type_idx;

   TRACE (Func_Entry, "gen_temp_init", NULL);

   type_idx = ATD_TYPE_IDX(attr_idx);
   line = AT_DEF_LINE(attr_idx);
   col = AT_DEF_COLUMN(attr_idx);

   if (SB_RUNTIME_INIT(ATD_STOR_BLK_IDX(attr_idx))) {

      /* The var is on the stack, or is automatic, a darg or a func  */
      /* result.  Generate runtime code for the initialization.      */

      ir_idx = gen_ir(AT_Tbl_Idx, attr_idx,
                  Asg_Opr, type_idx, line, col,
                      CN_Tbl_Idx, cn_idx);

      gen_opnd(&opnd, ir_idx, IR_Tbl_Idx, line, col);

      sh_idx                       = ntr_sh_tbl();
      SH_STMT_TYPE(sh_idx)         = Assignment_Stmt;
      SH_GLB_LINE(sh_idx)          = line;
      SH_COL_NUM(sh_idx)           = col;
      SH_COMPILER_GEN(sh_idx)      = TRUE;
      SH_P2_SKIP_ME(sh_idx)        = TRUE;

      SH_IR_IDX(sh_idx) = ir_idx;

      insert_sh_chain_after_entries(sh_idx, sh_idx);
   }
   else {
      ir_idx = gen_ir(AT_Tbl_Idx, attr_idx,
                  Init_Opr, TYPELESS_DEFAULT_TYPE, line, col,
                      IL_Tbl_Idx, gen_il(3,
                                         FALSE,
                                         line,
                                         col,
                                         CN_Tbl_Idx,
                                         cn_idx,
                                         CN_Tbl_Idx,
                                         CN_INTEGER_ONE_IDX,
                                         CN_Tbl_Idx,
                                         CN_INTEGER_ZERO_IDX));

      gen_sh(After,
             Type_Init_Stmt,
             line,
             col,
             FALSE,
             FALSE,
             TRUE);

      SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
      SH_IR_IDX(curr_stmt_sh_idx)     = ir_idx;

   }


   TRACE (Func_Exit, "gen_temp_init", NULL);

   return;

}  /* gen_temp_init */

#ifdef KEY /* Bug 5091 */
/*
 * attr_idx	AT_Tbl_Idx for an entity
 * returns	TRUE if the entity is readonly because it has the PROTECTED
 *		attribute and is accessed by use association
 */
boolean
readonly_protected(int attr_idx) {
  return (!AT_IS_DARG(attr_idx)) && AT_PROTECTED(attr_idx) &&
    AT_USE_ASSOCIATED(attr_idx);
}
#endif /* KEY Bug 5091 */
