xref: /dports/math/libpgmath/flang-d07daf3/tools/flang1/flang1exe/semfunc.c

/*
 * Copyright (c) 1994-2019, NVIDIA CORPORATION.  All rights reserved.
 *
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 *     http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *
 */

/** \file
    \brief Fortran front-end utility routines used by Semantic Analyzer to
           process functions, subroutines, predeclareds, etc.
 */

#include "gbldefs.h"
#include "global.h"
#include "error.h"
#include "symtab.h"
#include "symutl.h"
#include "dtypeutl.h"
#include "semant.h"
#include "scan.h"
#include "ilmtp.h"
#include "semstk.h"
#include "pd.h"
#include "machar.h"
#include "ast.h"
#include "rte.h"
#include "rtlRtns.h"
#include "version.h"
#include "atomic_common.h"

static struct {
  int nent;  /* number of arguments specified by user */
  int nargt; /* number actually needed for AST creation */
} carg;
static void add_typroc(int);
static void count_actuals(ITEM *);
static void count_formals(int);
static void count_formal_args(int, int);
static void check_dim_error(int, int);
static int mk_array_type(int, int);
static int gen_derived_arg(SST *, int, int, int);
static int gen_pointer_result(int, int, int, LOGICAL, int);
static int gen_allocatable_result(int, int, int, LOGICAL, int);
static int gen_array_result(int, int, int, LOGICAL, int);
static int gen_char_result(int, int, int);
static void precompute_arg_intrin(int, int);
static void precompute_args(int, int);
static void replace_arguments(int, int);
static void rewrite_triples(int, int, int);
static void rewrite_subscr(int, int, int);
static void replace_formal_triples(int, int, int);
static int getMergeSym(int, int);
static void ref_pd_subr(SST *, ITEM *);
static void ref_intrin_subr(SST *, ITEM *);
static int set_kind_result(SST *, int, int);
static int set_shape_result(int, int);
static int _adjustl(int);
static int _adjustr(int);
static int _index(int, int, int);
static int _len_trim(int);
static int _repeat(int, int);
static int _scan(int, int, int);
static int _trim(int);
static int _verify(int, int, int);
static void get_byval_ref(int, int);
static int find_byval_ref(int, int, int);
static int cmp_mod_scope(SPTR);

static void gen_init_intrin_call(SST *, int, int, int, int);
#ifdef I_C_ASSOCIATED
static int _c_associated(SST *, int);
#endif

static int get_type_descr_dummy(int sptr, int arg);
static int get_tbp(int sptr);
static void fix_proc_pointer_call(SST *, ITEM **);
static int find_by_name_stype_arg(char *, int, int, int, int, int);

static int _e74_sym;
static int _e74_cnt;
static int _e74_l;
static int _e74_u;
static int _e74_pos;
static char *_e74_kwd;
static void e74_cnt(int, int, int, int);
static void e74_arg(int, int, char *);
static int byvalue_ref_arg(SST *, int *, int, int);
static int gen_finalized_result(int fval, int func_sptr);

#define E74_CNT(s, c, l, u) (_e74_sym = s, _e74_cnt = c, _e74_l = l, _e74_u = u)
#define E74_ARG(s, p, k) (_e74_sym = s, _e74_pos = p, _e74_kwd = k)

#define ERR170(s) error(170, 2, gbl.lineno, s, CNULL)
#define HL_UF(s) \
  error(0, 3, gbl.lineno, "HPF Library procedure not implemented", SYMNAME(s))

#define GET_CVAL_ARG(i) get_sst_cval(ARG_STK(i))
#define GET_DBLE(x, y) \
  x[0] = CONVAL1G(y);  \
  x[1] = CONVAL2G(y)
#define GET_QUAD(x, y) \
  x[0] = CONVAL1G(y);  \
  x[1] = CONVAL2G(y);  \
  x[2] = CONVAL3G(y);  \
  x[3] = CONVAL4G(y);

static int byval_func_ptr = 0;
static int byval_dscptr = 0;
static int byval_paramct = 0;

#define PASS_BYVAL 1
#define PASS_BYREF 2
#define PASS_BYREF_NO_LEN 3
#define PASS_BYDEFAULT 0

/** \brief Return the "static type descriptor" for object sptr. The static
           type descriptor holds the "declared type" of an object.
 */
int
get_static_type_descriptor(int sptr)
{
  int sptrsdsc, dtype;

  dtype = DTYPEG(sptr);

  switch (DTY(dtype)) {
  case TY_DERIVED:
    break;
  case TY_ARRAY:
    dtype = DTY(dtype + 1);
    if (DTY(dtype) == TY_DERIVED) {
      sptr = DTY(dtype + 3);
      break;
    }
  default:
    return 0; /* TBD - probably need other cases for unlimited
               * polymorphic entities.
               */
  }

  sptrsdsc = SDSCG(sptr);
  if (sptrsdsc <= NOSYM) {
    set_descriptor_class(1);
    get_static_descriptor(sptr);
    set_descriptor_class(0);
    sptrsdsc = SDSCG(sptr);
  }
  DESCUSEDP(sptr, TRUE);
  NODESCP(sptr, FALSE);
  PARENTP(sptrsdsc, DTYPEG(sptr));
  if (DTY(DTYPEG(sptr)) == TY_DERIVED) {
    /* make sure all parent types get a descriptor as well */
    DTYPE dt = DTYPEG(sptr);
    SPTR tag = get_struct_tag_sptr(dt);
    SPTR member = get_struct_members(dt);
    int init_ict = get_struct_initialization_tree(dt);

    if (init_ict > 0) {
      SPTR init_template = get_dtype_init_template(dt);
      if (init_template > NOSYM)
        sym_is_refd(init_template);
    }

    while (member > NOSYM && PARENTG(member)) {
      DTYPE dt = DTYPEG(member);
      if ((tag = get_struct_tag_sptr(dt)) <= NOSYM)
        break;
      if (!SDSCG(member)) {
        set_descriptor_class(TRUE); /* this means "needs a type pointer" */
        get_static_descriptor(member);
        set_descriptor_class(FALSE); /* reset static flag that was set above */
        DESCUSEDP(member, TRUE);
        NODESCP(member, FALSE);
        PARENTP(SDSCG(member), dt);
      }
      member = get_struct_members(DTYPEG(tag));
    }
  }
  return sptrsdsc;
}

static int
get_type_descr_dummy(int sptr, int arg)
{

  int count, i, count_class;
  int dscptr, count_descr;
  LOGICAL found = FALSE;

  fix_class_args(sptr);
  count = PARAMCTG(sptr);
  dscptr = DPDSCG(sptr);
  count_class = count_descr = 0;
  for (i = 0; i < count; ++i) {
    int arg2 = aux.dpdsc_base[dscptr + i];
    if (!found) {
      if (strcmp(SYMNAME(arg), SYMNAME(arg2)) != 0) {
        if (CLASSG(arg2) && !needs_descriptor(arg2))
          ++count_class;
      } else {
        found = TRUE;
      }
    } else if (CCSYMG(arg2) && CLASSG(arg2)) {
      if (count_class == count_descr) {
        return arg2;
      }
      ++count_descr;
    }
  }

  return 0;
}

/** \brief Return the type descriptor associated with \a arg (and \a func_sptr
   when
           \a arg is a dummy argument of routine \a func_sptr).
 */
int
get_type_descr_arg(int func_sptr, int arg)
{
  int arg2, sptr;

  if (needs_descriptor(arg)) {
    if (SDSCG(arg) <= NOSYM)
      get_static_descriptor(arg);
    return SDSCG(arg);
  }

  if (CLASSG(arg) && SCG(arg) == SC_DUMMY) {
    sptr = get_type_descr_dummy(func_sptr, arg);
    if (!sptr && gbl.internal > 1) {
      sptr = get_type_descr_dummy(gbl.outersub, arg);
    }
#if DEBUG
    assert(sptr, "get_type_descr_arg: NULL dummy descriptor ", arg, 4);
#endif
    return sptr;
  }
  if (!CLASSG(arg)) {
    DTYPE dtype = DTYPEG(arg);
    if (DTY(dtype) == TY_DERIVED) {
      /* not polymorphic, so just return declared type descriptor */
      arg = DTY(dtype + 3);
    }
  }
  sptr = get_static_type_descriptor(arg);

#if DEBUG
  assert(sptr, "get_type_descr_arg: NULL descriptor ", arg, 4);
#endif

  return sptr;
}

/** \brief Same as get_type_descr_arg(), but do not perform error check.
 */
int
get_type_descr_arg2(int func_sptr, int arg)
{
  int arg2, sptr;
  if (needs_descriptor(arg)) {
    int desc;
    if (SDSCG(arg))
      desc = SDSCG(arg);
    else {
      int orig_sc = get_descriptor_sc();
      set_descriptor_sc(SC_STATIC);
      get_static_descriptor(arg);
      set_descriptor_sc(orig_sc);
      desc = SDSCG(arg);
    }
    return desc;
  }

  if (CLASSG(arg) && SCG(arg) == SC_DUMMY) {
    sptr = get_type_descr_dummy(func_sptr, arg);
    return sptr;
  }

  sptr = get_static_type_descriptor(arg);

  return sptr;
}

/* check if this is a character parameter, passed by reference,
   no length needed in the function parameter list
  */
static int
pass_char_no_len(int func_sptr, int param_sptr)
{
  return (find_byval_ref(func_sptr, param_sptr, 0) == PASS_BYREF_NO_LEN);
}

/** \brief Return true if \a sptr is an SC_LOCAL and a pass by value parameter
   of
           \a func_sptr.
 */
int
sc_local_passbyvalue(int sptr, int func_sptr)
{
  int dscptr;
  int i;
  int param_sptr;
  char *param_name;

  if (SCG(sptr) != SC_LOCAL)
    return 0;

  /* find the _V_var on the function list */
  dscptr = DPDSCG(func_sptr);
  for (i = PARAMCTG(func_sptr); i > 0; dscptr++, i--) {
    param_sptr = aux.dpdsc_base[dscptr];
    param_name = SYMNAME(param_sptr);
    if ((strncmp(param_name, "_V_", 3) == 0) &&
        (strcmp(param_name + 3, SYMNAME(sptr)) == 0))
      return 1;
  }
  return 0;
}

/* param_sptr is a character string.  return  PASS_BYVAL,
   PASS_BYREF, PASS_BYREF_NO_LEN
 */
static int
set_char_ref_val(int func, int param)
{
  if (func == 0)
    return (PASS_BYREF);
  if (PASSBYVALG(param))
    return PASS_BYVAL;
  if (STDCALLG(func) || CFUNCG(func)) {
    if (PASSBYREFG(param))
      return PASS_BYREF_NO_LEN;

    if (PASSBYREFG(func))
      return PASS_BYREF;

    /* plain func= c/stdcall is pass by value */
    return PASS_BYVAL;
  }

  return PASS_BYREF;
}

/* find_byval_ref: check STCALLG , CFUNCG, PASSBYREFG, PASSBYVALG  and
   decide if this parameter is pass by value , pass by reference,
   or a character parameter pass by ref without length
 */
static int
find_byval_ref(int func_sptr, int param_sptr, int any_type)
{
  int iface;
  /* special care must be taken to mark string types
     pass by reference when we do not pass a length
   */
  /* CDEC$ VALUE or REFERENCE set explicitly for this parameter */

  proc_arginfo(func_sptr, NULL, NULL, &iface);
  if (param_sptr <= 0) {
    if (iface == 0)
      return (PASS_BYDEFAULT);
    if (PASSBYVALG(iface)) {
      return (PASS_BYVAL);
    }
    if (PASSBYREFG(iface)) {
      return (PASS_BYREF);
    }
/* sub defaults implied by STDARG or CFUNC */
#ifdef CREFP
    if (!CREFG(iface) && (STDCALLG(iface) || CFUNCG(iface))) {
      return (PASS_BYVAL);
    }
#else
    if (STDCALLG(iface) || CFUNCG(iface)) {
      return (PASS_BYVAL);
    }
#endif
    return PASS_BYDEFAULT;
  }

  if ((DTY(DTYPEG(param_sptr)) == TY_CHAR) ||
      (DTY(DTYPEG(param_sptr)) == TY_NCHAR)) {
    return (set_char_ref_val(iface, param_sptr));
  }

  if (is_iso_cptr(DTYPEG(param_sptr)) && PASSBYVALG(param_sptr)) {
    return (PASS_BYVAL);
  }

  if (!any_type && ((DTY(DTYPEG(param_sptr)) == TY_ARRAY) ||
                    (DTY(DTYPEG(param_sptr)) == TY_UNION))) {
    return (PASS_BYREF);
  }

  if (PASSBYVALG(param_sptr)) {
    return (PASS_BYVAL);
  }
  if (PASSBYREFG(param_sptr)) {
    return (PASS_BYREF);
  }

  /* subroutine default setting of parameters :
     sub defaults were directly set CDEC$ ATTRIBUTE VALUE or REFERENCE
   */
  if (iface == 0)
    return (PASS_BYDEFAULT);
  if (PASSBYVALG(iface)) {
    return (PASS_BYVAL);
  }
  if (PASSBYREFG(iface)) {
    return (PASS_BYREF);
  }
  /* sub defaults implied by STDARG or CFUNC */
  if (STDCALLG(iface) || CFUNCG(iface)) {
    return (PASS_BYVAL);
  }

  return (PASS_BYDEFAULT);
}

static void
init_byval()
{
  byval_func_ptr = 0;
  byval_dscptr = 0;
  byval_paramct = 0;
}

/* return the next dummy parameter to check for
   by value
 */
static int
inc_dummy_param(int func_sptr)
{
  int param_sptr;
  int arg;

  if (byval_func_ptr == 0) {
    byval_func_ptr = func_sptr;
    byval_dscptr = DPDSCG(func_sptr);
    byval_paramct = PARAMCTG(func_sptr);
  }

  if (byval_paramct == 0)
    return 0;
  param_sptr = *(aux.dpdsc_base + byval_dscptr);
  byval_dscptr++;
  return (param_sptr);
}

/** \brief Return true if param is pass by value.
 */
int
get_byval(int func_sptr, int param_sptr)
{
  return find_byval_ref(func_sptr, param_sptr, 0) == PASS_BYVAL;
}

/* rewrite references to types c_ptr, c_loc_ptr as
   c-_ptr->member
 */
static int
rewrite_cptr_references(int ast)
{
  int past, mast;
  int new_ast = 0;
  int psptr;
  int msptr = 0;
  int iso_dtype;

  switch (A_TYPEG(ast)) {
  case A_ID:
    mast = ast;
    break;
  case A_MEM:
    mast = A_MEMG(ast);
    break;
  case A_SUBSCR:
    mast = A_LOPG(ast);
    break;
  default:
    /* no need to process further  all cases of possible
       nested C_PTR must be in cases above  */
    return 0;
  }

  /* check for type C_PTR, C_FUNC_PTR, and process */
  iso_dtype = is_iso_cptr(A_DTYPEG(mast));
  if (iso_dtype) {
    psptr = DTY(iso_dtype + 1);
    new_ast = mk_member(ast, mk_id(psptr), DTYPEG(psptr));
  }
  return new_ast;
}

/*---------------------------------------------------------------------*/
/*
 * This stack entry represents a subprogram argument to be passed by value.
 *
 */
/* from %VAL() and %REF() processing */
static int
byvalue_ref_arg(SST *e1, int *dtype, int op, int func_sptr)
{
  int dum;
  int saved_dtype;
  int new_ast = 0;

  if (op == OP_VAL || op == OP_BYVAL) {
    int argdt;
    if (SST_ISNONDECC(e1))
      cngtyp(e1, DT_INT);

    saved_dtype = A_DTYPEG(SST_ASTG(e1));

    if ((A_TYPEG(SST_ASTG(e1)) == A_FUNC) && (is_iso_cptr(saved_dtype)) && !CFUNCG(func_sptr)) {
      /* functions returning c_ptr structs become funcs
         returning ints, so that we simply copy the
         (integer)pointer
       */
      A_DTYPEP(SST_ASTG(e1), DT_PTR);
    } else {
      new_ast = rewrite_cptr_references(SST_ASTG(e1));
      if (new_ast) {
        SST_ASTP(e1, new_ast);
        SST_IDP(e1, S_EXPR);
        SST_DTYPEP(e1, A_DTYPEG(new_ast));
      }
    }

    /* checking the AST dtype, resetting the semantic stack dtype */
    if (A_DTYPEG(SST_ASTG(e1)) != saved_dtype) {
      SST_DTYPEP(e1, A_DTYPEG(SST_ASTG(e1)));
    }

    mkexpr(e1);
    SST_IDP(e1, S_VAL);
    argdt = SST_DTYPEG(e1);
    *dtype = argdt;
    if (ELEMENTALG(func_sptr))
      argdt = DDTG(argdt);

    if (!is_iso_cptr(argdt) && !DT_ISBASIC(argdt) && DTY(argdt) != TY_STRUCT &&
        DTY(argdt) != TY_DERIVED) {
      /* also allow passing chars with no loc */
      cngtyp(e1, DT_INT);
      errsev(52);
    }
    SST_ASTP(e1, mk_unop(op, SST_ASTG(e1), *dtype));
    return mkarg(e1, dtype);
  }
#if DEBUG
  assert(op == OP_REF, "byvalue_ref_arg bad op", op, 3);
#endif
  /* OP_REF(character) , no length passed */
  mkarg(e1, &dum);
  SST_IDP(e1, S_REF);

  SST_ASTP(e1, mk_unop(op, SST_ASTG(e1), DT_INT));
  return 1;
}

/** \brief Return TRUE if sptr is a derived type with an allocatable member */
LOGICAL
allocatable_member(int sptr)
{
  DTYPE dtype = DTYPEG(sptr);
  if (DTYG(dtype) == TY_DERIVED) {
    int sptrmem;
    for (sptrmem = DTY(DDTG(dtype) + 1); sptrmem > NOSYM;
         sptrmem = SYMLKG(sptrmem)) {
      if (ALLOCATTRG(sptrmem)) {
        return TRUE;
      }
      if (USELENG(sptrmem) && ALLOCG(sptrmem) && TPALLOCG(sptrmem)) {
        return TRUE; /* uses length type parameter */
      }
      if (is_tbp_or_final(sptrmem)) {
        continue; /* skip tbp */
      }
      if (dtype != DTYPEG(sptrmem) && !POINTERG(sptrmem) &&
          allocatable_member(sptrmem)) {
        return TRUE;
      }
    }
  }
  return FALSE;
}

/*---------------------------------------------------------------------*/
LOGICAL
in_kernel_region()
{
  int df;
  for (df = 1; df <= sem.doif_depth; df++) {
    switch (DI_ID(df)) {
    case DI_CUFKERNEL:
    case DI_ACCDO:
    case DI_ACCLOOP:
    case DI_ACCREGDO:
    case DI_ACCREGLOOP:
    case DI_ACCKERNELSDO:
    case DI_ACCKERNELSLOOP:
    case DI_ACCPARALLELDO:
    case DI_ACCPARALLELLOOP:
    case DI_ACCSERIALLOOP:
      return TRUE;
    }
  }
  return FALSE;
} /* in_kernel_region */
/*---------------------------------------------------------------------*/

static int
get_sym_from_sst_if_available(SST *sst_actual)
{
  int sptr = 0;
  int unused;
  int ast;

  if (SST_IDG(sst_actual) == S_LVALUE)
    sptr = SST_LSYMG(sst_actual);
  else if (SST_IDG(sst_actual) == S_DERIVED || SST_IDG(sst_actual) == S_IDENT)
    sptr = SST_SYMG(sst_actual);
  else if (SST_IDG(sst_actual) == S_SCONST) {
    (void)mkarg(sst_actual, &unused);
    sptr = SST_SYMG(sst_actual);
  }
  return sptr;
}

static LOGICAL
is_ptr_arg(SST *sst_actual)
{
  SPTR sptr = get_sym_from_sst_if_available(sst_actual);

  if (sptr <= NOSYM) {
    int ast = SST_ASTG(sst_actual);
    if (A_TYPEG(ast) == A_INTR && A_OPTYPEG(ast) == I_NULL) {
      return TRUE;
    }
    if (A_TYPEG(ast) == A_ID) {
      sptr = A_SPTRG(ast);
      if (sptr > NOSYM && SCG(sptr) == SC_BASED && !ALLOCATTRG(sptr) &&
          MIDNUMG(sptr) > NOSYM && PTRVG(MIDNUMG(sptr)))
        return TRUE;
    }
    if (SST_IDG(sst_actual) == S_EXPR && A_TYPEG(ast) == A_FUNC) {
      sptr = memsym_of_ast(A_LOPG(ast));
      sptr = FVALG(sptr);
    }
  }

  return sptr > NOSYM && POINTERG(sptr);
}

/* Non-pointer passed to a pointer dummy: geneerate a pointer temp, associate
 * the temp with the actual arg, and pass the temp.
 */
static int
gen_and_assoc_tmp_ptr(SST *sst_actual, int std)
{
  int sptrtmp;
  int ast_actual;
  int asttmp;
  int ast;
  int dtype;
  int dtype1;

  ast_actual = SST_ASTG(sst_actual);

  if (SST_IDG(sst_actual) == S_EXPR) {
    dtype1 = A_DTYPEG(ast_actual);
    ast = sem_tempify(sst_actual);
    (void)add_stmt(ast);
    ast = A_DESTG(ast);
  } else if (ast_actual) {
    dtype1 = A_DTYPEG(ast_actual);
    ast = ast_actual;
  } else {
    int sptractual = get_sym_from_sst_if_available(sst_actual);
    assert(sptractual, "gen_and_assoc_tmp_ptr: no symbol or AST for actual arg",
           0, 4);
    dtype1 = DTYPEG(sptractual);
    ast = mk_id(sptractual);
  }

  dtype = dtype1;
  if (DTY(dtype) == TY_ARRAY) {
    dtype = dup_array_dtype(dtype);
    DTY(dtype + 1) = DTY(dtype1 + 1);
  }

  sptrtmp = getcctmp_sc('d', sem.dtemps++, ST_VAR, dtype, SC_LOCAL);
  asttmp = mk_id(sptrtmp);
  POINTERP(sptrtmp, 1);
  CCSYMP(sptrtmp, 1);
  ARGP(sptrtmp, 1);
  get_static_descriptor(sptrtmp);
  get_all_descriptors(sptrtmp);
  ADDRTKNP(sym_of_ast(ast), 1);
  (void)add_stmt(add_ptr_assign(asttmp, ast, std));
  return asttmp;
}

static LOGICAL
need_tmp_retval(int func_sptr, int param_dummy)
{
  int fval;
  int func_dtype;

  fval = func_sptr;
  if (FVALG(func_sptr))
    fval = FVALG(func_sptr);

  func_dtype = DTYPEG(func_sptr);

  if (POINTERG(fval)) {
    return TRUE;
  }
  if (POINTERG(fval)) {
    return TRUE;
  }
  if (ALLOCATTRG(fval) || allocatable_member(fval)) {
    return TRUE;
  }
  if (DTY(func_dtype) == TY_ARRAY) {
    return TRUE;
  }
  if (ADJLENG(fval)) {
    if (!ELEMENTALG(func_sptr)) {
      return TRUE;
    } else if (!ARG_STK(0) || !A_SHAPEG(SST_ASTG(ARG_STK(0)))) {
      return TRUE;
    }
  }

  return FALSE;
}

/** \brief If applicable, generate finalization code for function result.
 *
 * \param fval is the result symbol.
 * \param func_sptr is the function symbol table pointer
 *
 * \returns the result symbol; either fval or a new result symbol.
 */
static int
gen_finalized_result(int fval, int func_sptr)
{
  if (!ALLOCATTRG(fval) && !POINTERG(fval) && has_finalized_component(fval)) {
    /* Need to finalize the function result after it's assigned to LHS.
     * If the result is allocatable, then finalization is handled during
     * automatic deallocation (i.e., the runtime call to dealloc_poly03,
     * dealloc_poly_mbr03). If the result is pointer, then we do not finalize
     * the object (the language spec indicates that it is processor dependent
     * whether such objects are finalized).
     */
    int std = add_stmt(mk_stmt(A_CONTINUE, 0));

    if (STYPEG(fval) == ST_UNKNOWN || STYPEG(fval) == ST_IDENT) {
      fval = getsymbol(SYMNAME(fval));
      if (STYPEG(fval) == ST_PROC) {
        /* function result variable name same as its function */
        fval = insert_sym(fval);
      } else {
        /* function result variable name overloads another object */
        fval = get_next_sym(SYMNAME(fval), NULL);
      }
      fval = declsym(fval, ST_VAR, TRUE);
      SCP(fval, SC_LOCAL);
      DTYPEP(fval, DTYPEG(func_sptr));
      DCLDP(fval, 1);
      init_derived_type(fval, 0, std);
      std = add_stmt(mk_stmt(A_CONTINUE, 0));
    }
    gen_finalization_for_sym(fval, std, 0);
  }
  return fval;
}

/** \brief Write ILMs to call a function.
    \param stktop function to call
    \param list   arguments to pass to function
    \param flag   set if called from a generic resolution routine
 */
int
func_call2(SST *stktop, ITEM *list, int flag)
{
  int func_sptr, sptr1, fval_sptr = 0;
  ITEM *itemp;
  int count, i, ii;
  int dum;
  int dtype;
  int ast;
  int argt;
  SST *sp;
  int param_dummy;
  int return_value, isarray, save_func_arrinfo;
  char *kwd_str; /* where make_kwd_str saves the string */
  int argt_count;
  int shaper;
  int new_ast;
  int psptr, msptr;
  int callee;
  int invobj;
  int doif;

  return_value = 0;
  save_func_arrinfo = 0;
  SST_CVLENP(stktop, 0);
  ast = astb.i0; /* initialize just in case error occurs */
  kwd_str = NULL;
  func_sptr = SST_SYMG(stktop);
  if (func_sptr < 0) {
    func_sptr = -func_sptr;
    SST_SYMP(stktop, func_sptr);
  }
  switch (A_TYPEG(SST_ASTG(stktop))) {
  case A_ID:
  case A_LABEL:
  case A_ENTRY:
  case A_SUBSCR:
  case A_SUBSTR:
  case A_MEM:
    callee = memsym_of_ast(SST_ASTG(stktop));
    if (STYPEG(callee) == ST_PROC && CLASSG(callee) && IS_TBP(callee)) {
      /* special case for user defined generic type bound operators */
      i = 0;
      func_sptr = get_implementation(TBPLNKG(callee), callee, 0, &i);
      if (STYPEG(BINDG(i)) == ST_OPERATOR ||
          STYPEG(BINDG(i)) == ST_USERGENERIC) {
        i = get_specific_member(TBPLNKG(callee), callee);
        func_sptr = VTABLEG(i);
      }
      callee = i;
      SST_ASTP(stktop, replace_memsym_of_ast(SST_ASTG(stktop), i));
      dtype = TBPLNKG(BINDG(i));
      goto process_tbp;
    }
    break;
  default:
    callee = 0;
  }
  if (callee && CLASSG(callee) && CCSYMG(callee) &&
      STYPEG(callee) == ST_MEMBER) {
    func_sptr = pass_sym_of_ast(SST_ASTG(stktop));
    dtype = DTYPEG(func_sptr);
    if (DTY(dtype) == TY_ARRAY)
      dtype = DTY(dtype + 1);
    if (STYPEG(BINDG(callee)) == ST_USERGENERIC) {
      int mem;
      func_sptr = generic_tbp_func(BINDG(callee), stktop, list);
      if (func_sptr) {
        if (get_implementation(dtype, func_sptr, 0, &mem) == 0) {
          char *name_cpy, *name;
          name_cpy = getitem(0, strlen(SYMNAME(func_sptr)) + 1);
          strcpy(name_cpy, SYMNAME(func_sptr));
          name = strchr(name_cpy, '$');
          if (name)
            *name = '\0';
          error(155, 3, gbl.lineno,
                "Could not resolve generic type bound "
                "procedure",
                name_cpy);
          sptr1 = 0;
        } else {
          SST_ASTP(stktop, replace_memsym_of_ast(SST_ASTG(stktop), mem));
          callee = mem;
        }
      }
    }
    func_sptr = get_implementation(dtype, BINDG(callee), !flag, NULL);
  process_tbp:
    invobj = get_tbp_argno(BINDG(callee), dtype);
    set_pass_objects(invobj - 1, pass_sym_of_ast(SST_ASTG(stktop)));
    callee = SST_ASTG(stktop);
  } else
    callee = 0;
  FUNCP(func_sptr, 1); /* mark sptr as a function */
  TYPDP(func_sptr, 1); /* put in 'external' statement */
  dtype = DTYPEG(func_sptr);
  shaper = 0;
  isarray = DTY(dtype) == TY_ARRAY;

  if (DPDSCG(func_sptr))
    kwd_str = make_kwd_str(func_sptr);

  /* store function st in ERRSYM for error messages; used to be set only
   * for CHAR
   */
  SST_ERRSYMP(stktop, func_sptr);

  if (list == NULL)
    list = ITEM_END;
  if (STYPEG(func_sptr) == ST_PROC && SLNKG(func_sptr) == 0) {
    SLNKP(func_sptr, aux.list[ST_PROC]);
    aux.list[ST_PROC] = func_sptr;
  }
  count_actuals(list);
  count = carg.nent;
  argt_count = carg.nargt;

  if (!FUNCLINEG(func_sptr) && POINTERG(func_sptr)) {
    error(465, 3, gbl.lineno, CNULL, CNULL);
  }
  init_byval();

  if (kwd_str) {
    int dscptr; /* ptr to dummy parameter descriptor list */
    int fval;

    if (check_arguments(func_sptr, count, list, kwd_str))
      goto exit_;
    for (i = 0; i < carg.nent; i++) {
      sp = ARG_STK(i);
      if (sp) {
        /* add to ARGT list, handling derived type arguments as
         * special case.
         */
        sptr1 = get_sym_from_sst_if_available(sp);
        {
          param_dummy = inc_dummy_param(func_sptr);

          if (is_iso_cloc(SST_ASTG(sp))) {
            if (find_byval_ref(func_sptr, param_dummy, 1) == PASS_BYVAL) {
              /* pass by val iso_c pointer to arg:
                 C_LOC(arg)   C_FUN_LOC(arg)
                 is plain old pass by reference
                 without type checking: get rid of the
                C_LOC:
               */
              new_ast = ARGT_ARG(A_ARGSG(SST_ASTG(sp)), 0);
              if (A_TYPEG(new_ast) == A_ID && (!TARGETG(A_SPTRG(new_ast))) &&
                  (!POINTERG(A_SPTRG(new_ast))))
                errwarn(468);

              SST_ASTP(sp, new_ast);
              SST_IDP(sp, S_EXPR);
            } else if (A_TYPEG(ARGT_ARG(A_ARGSG(SST_ASTG(sp)), 0)) != A_ID) {
              // Inlining has problems with an expression in this context.
              // Downstream code can always handle simple variables.
              (void)tempify(sp);
            }
            /* else
             * iso_c_loc by reference pointer to pointer */
          } else if (get_byval(func_sptr, param_dummy)) {
            /*  function arguments not processed by lowerilm */
            if (PASSBYVALG(param_dummy)) {
              if (OPTARGG(param_dummy)) {
                int assn = sem_tempify(sp);
                (void)add_stmt(assn);
                SST_ASTP(sp, A_DESTG(assn));
                byvalue_ref_arg(sp, &dum, OP_REF, func_sptr);
              } else if (!need_tmp_retval(func_sptr, param_dummy))
                byvalue_ref_arg(sp, &dum, OP_BYVAL, func_sptr);
              else
                byvalue_ref_arg(sp, &dum, OP_VAL, func_sptr);
            } else {
              byvalue_ref_arg(sp, &dum, OP_VAL, func_sptr);
            }
          } else if (pass_char_no_len(func_sptr, param_dummy)) {
            byvalue_ref_arg(sp, &dum, OP_REF, func_sptr);
          } else if (INTENTG(param_dummy) == INTENT_IN &&
                     POINTERG(param_dummy) && !is_ptr_arg(sp)) {
            /* F2008: pass non-pointer actual arg for an
             *        INTENT(IN), POINTER formal arg */
            ARG_AST(i) = SST_ASTG(sp) = gen_and_assoc_tmp_ptr(sp, sem.last_std);
          } else {
          }
        }
      }
    }

    count_formals(func_sptr);
    argt_count = carg.nargt;
    dscptr = DPDSCG(func_sptr);
    fval = func_sptr;
    if (FVALG(func_sptr))
      fval = FVALG(func_sptr);
    /* for ST_ENTRY, the data type info is set in the return value symbol */
    if (POINTERG(fval)) {
      /*
       * since the result of the function is a pointer, a pointer
       * temporary must be created.
       * Note that for an 'adjustable' return value, its size
       * may be dependent on the actual arguments.
       *
       * Would like to call set_descriptor_sc() at the beginning
       * of func2_call() and restore at the end; however, there
       * are still semsym things that might need to be done to user
       * variables.  So, only call set_descriptor_sc() when we know
       * we are creating temps.
       */
      set_descriptor_sc(sem.sc);
      if (isarray) {
        return_value = ref_entry(func_sptr);
      } else {
        return_value = get_next_sym(SYMNAME(func_sptr), "v");
        STYPEP(return_value, ST_VAR);
        SCP(return_value, SC_BASED);
        DTYPEP(return_value, dtype);
        DCLDP(return_value, 1);
        POINTERP(return_value, 1);
        if (DTYG(dtype) == TY_DERIVED && XBIT(58, 0x40000)) {
          F90POINTERP(return_value, 1);
        } else {
          get_static_descriptor(return_value);
          get_all_descriptors(return_value);
        }
      }
#ifdef CLASSG
      if (HCCSYMG(return_value) && !CLASSG(return_value))
        CLASSP(return_value, CLASSG(FVALG(func_sptr)));
#endif
      {
        /* Be warned: "return_value" is a symbol table index coming into
         * this block of code, but it's an AST index coming out!
         */
        return_value = gen_pointer_result(return_value, dscptr, carg.nent,
                                          FALSE, func_sptr);
        argt_count++;
        argt = mk_argt(argt_count); /* mk_argt stuffs away count */
        ARGT_ARG(argt, 0) = return_value;
        ii = 1;
        save_func_arrinfo = 1;
      }
      set_descriptor_sc(SC_LOCAL);
    } else if (ALLOCATTRG(fval)) {
      /*
       * result of the function is an allocatable, should be similiar
       * to a pointer
       */
      if (isarray) {
        fval_sptr = ref_entry(func_sptr);
      } else {
        fval_sptr = get_next_sym(SYMNAME(func_sptr), "v");
        STYPEP(fval_sptr, ST_VAR);
        SCP(fval_sptr, SC_BASED);
        DTYPEP(fval_sptr, dtype);
        DCLDP(fval_sptr, 1);
        set_descriptor_sc(sem.sc);
        get_static_descriptor(fval_sptr);
        get_all_descriptors(fval_sptr);
        set_descriptor_sc(SC_LOCAL);
      }

      return_value = gen_allocatable_result(
          fval_sptr, dscptr, carg.nent, (DTYG(dtype) == TY_DERIVED), func_sptr);
#ifdef RVALLOCP
      if (XBIT(54, 0x1) && !isarray && DTY(dtype) != TY_DERIVED) {
        int sym;
        sym = sym_of_ast(return_value);
        if (MIDNUMG(sym)) {
          RVALLOCP(MIDNUMG(sym), 1);
        }
      }
#endif

#ifdef CLASSG
      if (HCCSYMG(fval_sptr) && !CLASSG(fval_sptr)) {
        CLASSP(fval_sptr, CLASSG(FVALG(func_sptr)));
        CLASSP(sym_of_ast(return_value), CLASSG(FVALG(func_sptr)));
      }
#endif
      argt_count++;
      argt = mk_argt(argt_count); /* mk_argt stuffs away count */
      ARGT_ARG(argt, 0) = return_value;
      ii = 1;
      add_p_dealloc_item(memsym_of_ast(return_value));
    } else if (allocatable_member(fval)) {
      if (ELEMENTALG(func_sptr)) {
        int i;
        for (i = 0; i < argt_count; ++i) {
          shaper = A_SHAPEG(ARG_AST(i));
          if (shaper) {
            int dt = dtype_with_shape(dtype, shaper);
            fval_sptr = get_arr_temp(dt, FALSE, FALSE, FALSE);
            DTYPEP(fval_sptr, dt);
            STYPEP(fval_sptr, ST_ARRAY);
            break;
          }
        }
      }
      if (!shaper) {
        if (ADJARRG(fval)) {
          return_value = ref_entry(func_sptr);
          return_value = gen_array_result(return_value, dscptr, carg.nent,
                                          FALSE, func_sptr);
          fval_sptr = A_SPTRG(return_value);
        } else {
          fval_sptr = get_next_sym(SYMNAME(func_sptr), "d");
          if (isarray) {
            STYPEP(fval_sptr, ST_ARRAY);
          } else {
            STYPEP(fval_sptr, ST_VAR);
          }
          DTYPEP(fval_sptr, dtype);
        }
      }

      SCP(fval_sptr, sem.sc);
      if (ASSUMSHPG(fval) || ASUMSZG(fval)) {
        set_descriptor_sc(sem.sc);
        get_static_descriptor(fval_sptr);
        get_all_descriptors(fval_sptr);
        set_descriptor_sc(SC_LOCAL);
      }
      init_derived_type(fval_sptr, 0, STD_PREV(0));
      argt_count++;
      argt = mk_argt(argt_count); /* mk_argt stuffs away count */
      return_value = mk_id(fval_sptr);
      ARGT_ARG(argt, 0) = return_value;
      ii = 1;
      add_p_dealloc_item(fval_sptr);
    } else if (isarray) {
      /*
       * since the result of the function is an array, a temporary
       * must be allocated at run-time even if its bounds are contant.
       * Note that for an 'adjustable' return value, its size
       * may be dependent on the actual arguments.
       */
      return_value = ref_entry(func_sptr);
      if (!ADJLENG(fval))
        return_value =
            gen_array_result(return_value, dscptr, carg.nent, FALSE, func_sptr);
      else
        return_value = gen_char_result(return_value, dscptr, carg.nent);
      argt_count++;
      argt = mk_argt(argt_count); /* mk_argt stuffs away count */
      ARGT_ARG(argt, 0) = return_value;
      ii = 1;
      /*
       * have an array-valued function; save up information
       * which would allow substituting the result temp with
       * the LHS of an assignment.
       */
      save_func_arrinfo = 1;
    } else if (ADJLENG(fval)) {
      if (ELEMENTALG(func_sptr)) {
        sp = ARG_STK(0);
        if (sp && (shaper = A_SHAPEG(SST_ASTG(sp)))) {
          argt_count++;
          argt = mk_argt(argt_count);
          ARGT_ARG(argt, 0) = gen_char_result(fval, dscptr, carg.nent);
          ii = 1;
          return_value = 0;
        } else {
          return_value = gen_char_result(fval, dscptr, carg.nent);
        }
      } else {
        return_value = gen_char_result(fval, dscptr, carg.nent);
      }
      if (return_value) {
        argt_count++;
        argt = mk_argt(argt_count); /* mk_argt stuffs away count */
        ARGT_ARG(argt, 0) = return_value;
        ii = 1;
      }
    } else {
      argt = mk_argt(argt_count); /* mk_argt stuffs away count */
      ii = 0;
    }

    fval = gen_finalized_result(fval, func_sptr);

    /* return value handled, copy in the function args */
    for (i = 0; i < carg.nent; i++, ii++) {
      if (ARG_STK(i)) {
        ARGT_ARG(argt, ii) = SST_ASTG(ARG_STK(i));
      } else {
        /* OPTIONAL arg not present */
        ARGT_ARG(argt, ii) = astb.ptr0;
      }
    }

    if (return_value) {
      /* return_value is symbol if result is of derived type;
       * otherwise, it's an ast.
       */
      dtype = DTYPEG(A_SPTRG(return_value));
      if (callee) {
        int mem = memsym_of_ast(callee);
        if (STYPEG(mem) == ST_MEMBER && !strstr(SYMNAME(func_sptr), "$tbp")) {
          VTABLEP(mem, func_sptr);
        }
        /*dtype = DTYPEG(mem);*/
      }
      ast = mk_func_node(A_CALL, (callee) ? callee : mk_id(func_sptr),
                         argt_count, argt);
      sem.arrfn.call_std = add_stmt(ast);
      sem.arrfn.sptr = func_sptr;
      if (save_func_arrinfo) {
        sem.arrfn.return_value = return_value;
        if (ALLOCG(A_SPTRG(return_value)))
          sem.arrfn.alloc_std = sem.alloc_std;
      }
      ast = return_value;
    } else {
      if (callee) {
        int mem = memsym_of_ast(callee);
        if (STYPEG(mem) == ST_MEMBER && !strstr(SYMNAME(func_sptr), "$tbp")) {
          VTABLEP(mem, func_sptr);
        }
        /*dtype = DTYPEG(mem);*/
      }
      ast = mk_func_node(A_FUNC, (callee) ? callee : mk_id(func_sptr),
                         argt_count, argt);
    }
    if (ELEMENTALG(func_sptr)) {
      int argc;
      for (argc = 0; argc < argt_count; ++argc) {
        /* Use first shaped argument */
        shaper = A_SHAPEG(ARGT_ARG(argt, argc));
        if (shaper)
          break;
      }
      if (shaper == 0) {
        shaper = mkshape(dtype);
      } else {
        dtype = dtype_with_shape(dtype, shaper);
        A_SHAPEP(ast, shaper);
      }
    } else {
      shaper = mkshape(dtype);
    }
    A_DTYPEP(ast, dtype);
    if (DFLTG(func_sptr)) {
      int newdt = dtype;
      switch (DTY(dtype)) {
      case TY_INT:
        newdt = stb.user.dt_int;
        break;
      case TY_LOG:
        newdt = stb.user.dt_log;
        break;
      case TY_REAL:
        newdt = stb.user.dt_real;
        break;
      case TY_CMPLX:
        newdt = stb.user.dt_cmplx;
        break;
      }
      if (newdt != dtype) {
        ast = mk_convert(ast, newdt);
        dtype = newdt;
      }
    }
    goto exit_;
  }
  ii = 0;
  /* before processing arguments, add derived type return values if needed */
  argt = mk_argt(argt_count); /* mk_argt stuffs away count */

  for (itemp = list; itemp != ITEM_END; itemp = itemp->next) {
    sp = itemp->t.stkp;
    if (SST_IDG(sp) == S_KEYWORD) {
      /* form is <ident> = <expression> */
      error(79, 3, gbl.lineno, scn.id.name + SST_CVALG(itemp->t.stkp), CNULL);
      itemp->t.sptr = 1;
      ARGT_ARG(argt, ii) = astb.i0;
      ii++;
      continue;
    }
    if (SST_IDG(sp) == S_TRIPLE) {
      /* form is e1:e2:e3 */
      error(76, 3, gbl.lineno, SYMNAME(func_sptr), CNULL);
      itemp->t.sptr = 1;
      ARGT_ARG(argt, ii) = astb.i0;
      ii++;
      continue;
    }
    if (SST_IDG(sp) == S_LABEL) {
      error(155, 3, gbl.lineno, "Illegal use of alternate return specifier",
            CNULL);
      ARGT_ARG(argt, ii) = astb.i0;
      ii++;
      continue;
    }
    /* check arguments and add to ARGT list, handling derived type
       arguments as special case */
    sptr1 = 0;
    if (SST_IDG(sp) == S_DERIVED || SST_IDG(sp) == S_IDENT)
      sptr1 = SST_SYMG(sp);
    else if (SST_IDG(sp) == S_LVALUE)
      sptr1 = SST_LSYMG(sp);
    else if (SST_IDG(sp) == S_SCONST) {
      (void)mkarg(sp, &dum);
      sptr1 = SST_SYMG(sp);
    }
    {
      /* form is <ident> or <expression> */
      param_dummy = inc_dummy_param(func_sptr);
      /*  function arguments not processed bylowerilm */

      if ((A_TYPEG(SST_ASTG(sp)) == A_ID) &&
          is_iso_cptr(DTYPEG(A_SPTRG(SST_ASTG(sp))))) {
        if (find_byval_ref(func_sptr, param_dummy, 1) == PASS_BYVAL) {
          /* iso cptr passed by value needs to transform into
             pass by value cptr->member : (pass the pointer
             sitting in cptr->member by value) */

          psptr = A_SPTRG(SST_ASTG(sp));
          msptr = DTY(DTYPEG(psptr) + 1);
          new_ast = mk_member(SST_ASTG(sp), mk_id(msptr), DTYPEG(msptr));
          SST_ASTP(sp, new_ast);
          SST_IDP(sp, S_EXPR);
          SST_DTYPEP(sp, DTYPEG(msptr));

          byvalue_ref_arg(sp, &dum, OP_VAL, func_sptr);
          ARGT_ARG(argt, ii) = SST_ASTG(sp);
        } else {
          /* plain pass by ref */
          itemp->t.sptr = chkarg(sp, &dum);
          ARGT_ARG(argt, ii) = SST_ASTG(sp);
        }
      } else if (is_iso_cloc(SST_ASTG(sp))) {

        if (find_byval_ref(func_sptr, param_dummy, 1) == PASS_BYVAL) {
          /* pass by val iso_c pointer to arg:
             C_LOC(arg)   C_FUN_LOC(arg)
             is plain old pass by reference
             without type checking: get rid of the c_LOC
           */
          new_ast = ARGT_ARG(A_ARGSG(SST_ASTG(sp)), 0);
          if (A_TYPEG(new_ast) == A_ID && (!TARGETG(A_SPTRG(new_ast))) &&
              (!POINTERG(A_SPTRG(new_ast))))
            errwarn(468);

          SST_ASTP(sp, new_ast);
          SST_IDP(sp, S_EXPR);
          ARGT_ARG(argt, ii) = SST_ASTG(sp);

        } else {
          /* iso_c_loc by reference: pointer to pointer */
          ARGT_ARG(argt, ii) = SST_ASTG(sp);
        }
      } else if (get_byval(func_sptr, param_dummy)) {
        if (PASSBYVALG(param_dummy)) {
          itemp->t.sptr = byvalue_ref_arg(sp, &dum, OP_BYVAL, func_sptr);
        } else {
          itemp->t.sptr = byvalue_ref_arg(sp, &dum, OP_VAL, func_sptr);
        }
        ARGT_ARG(argt, ii) = SST_ASTG(sp);
      } else if (pass_char_no_len(func_sptr, param_dummy)) {
        itemp->t.sptr = byvalue_ref_arg(sp, &dum, OP_REF, func_sptr);
        ARGT_ARG(argt, ii) = SST_ASTG(sp);
      } else {
        itemp->t.sptr = chkarg(sp, &dum);
        ARGT_ARG(argt, ii) = SST_ASTG(sp);
      }
      ii++;
    }
  }
  if (callee) {
    int mem = memsym_of_ast(callee);
    if (STYPEG(mem) == ST_MEMBER && !strstr(SYMNAME(func_sptr), "$tbp")) {
      VTABLEP(mem, func_sptr);
    }
    dtype = DTYPEG(mem);
  }
  ast = mk_func_node(A_FUNC, (callee) ? callee : mk_id(func_sptr), argt_count,
                     argt);
  A_DTYPEP(ast, dtype);
  A_SHAPEP(ast, mkshape(dtype));
  if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR)
    error(89, 3, gbl.lineno, SYMNAME(func_sptr), CNULL);

exit_:
  SST_IDP(stktop, S_EXPR);
  SST_ASTP(stktop, ast);
  if (shaper)
    SST_SHAPEP(stktop, shaper);
  else
    SST_SHAPEP(stktop, A_SHAPEG(ast));
  SST_DTYPEP(stktop, dtype);

exit_2:
  if (kwd_str)
    FREE(kwd_str);

  return 1;
}

/** \brief Resolve forward references in function func_call().
 *
 * Used by func_call() to resolve any forward refs we may
 * encounter since resolve_fwd_refs() in semutil.c gets called after we
 * finish processing this function. We also want to check to see if this
 * reference resolves to a generic procedure.
 */
static void
resolve_fwd_ref(int ref)
{
  int mod, decl, hashlk;
  int found;

  if (STYPEG(ref) == ST_PROC && FWDREFG(ref)) {
    found = 0;
    /* Find the module that contains the reference. */
    for (mod = SCOPEG(ref); mod; mod = SCOPEG(mod))
      if (STYPEG(mod) == ST_MODULE)
        break;
    if (mod == 0)
      return; /* Not in a module. */

    /* Look for the matching declaration. */
    for (decl = first_hash(ref); decl; decl = HASHLKG(decl)) {
      if (NMPTRG(decl) != NMPTRG(ref))
        continue;
      if (STYPEG(decl) == ST_PROC && ENCLFUNCG(decl) == mod) {
        hashlk = HASHLKG(ref);
        *(stb.stg_base + ref) = *(stb.stg_base + decl);
        HASHLKP(ref, hashlk);
        found = 1;
        break;
      }
    }
    if (found)
      return;
    /* Look for the matching generic declaration. */
    for (decl = first_hash(ref); decl; decl = HASHLKG(decl)) {
      if (NMPTRG(decl) != NMPTRG(ref))
        continue;
      if (STYPEG(decl) == ST_USERGENERIC && ENCLFUNCG(decl) == mod) {
        hashlk = HASHLKG(ref);
        *(stb.stg_base + ref) = *(stb.stg_base + decl);
        HASHLKP(ref, hashlk);
        found = 1;
        break;
      }
    }
  }
}

int
func_call(SST *stktop, ITEM *list)
{
  int func_sptr;
  /* Note: If we have a generic tbp (or operator), pass a 0
   * flag only if the generic is private. We do this to turn off
   * the private error check on the resolved tbp.
   */
  int ast, flag, sptr, sptr1 = NOSYM;
  ast = SST_ASTG(stktop);
  switch (A_TYPEG(ast)) {
  case A_ID:
  case A_LABEL:
  case A_ENTRY:
  case A_SUBSCR:
  case A_SUBSTR:
  case A_MEM:
    sptr1 = memsym_of_ast(ast);
    sptr = BINDG(sptr1);
    break;
  }

  if (A_TYPEG(ast) != A_MEM && sptr1 > NOSYM && IS_TBP(sptr1)) {
    /* Check for generic function that might be sharing the same
     * name as a type bound procedure
     */
    generic_func(SST_SYMG(stktop), stktop, list);
    sptr = SST_SYMG(stktop);
  }

  if ((STYPEG(sptr) == ST_USERGENERIC || STYPEG(sptr) == ST_OPERATOR) &&
      IS_TBP(sptr)) {
    return func_call2(stktop, list, sptr1 <= NOSYM || !PRIVATEG(sptr1));
  }
  /* Check to see if func_sptr is a forward reference that
   * resolves to an ST_PROC or a ST_USERGENERIC
   */
  func_sptr = SST_SYMG(stktop);
  if (func_sptr < 0) {
    func_sptr = -func_sptr;
  }
  resolve_fwd_ref(func_sptr);
  if (STYPEG(func_sptr) == ST_USERGENERIC)
    return generic_func(func_sptr, stktop, list);

  return func_call2(stktop, list, 0);
}

int
ptrfunc_call(SST *stktop, ITEM *list)
{
  int func_sptr, sptr1, fval_sptr;
  int callee;
  ITEM *itemp;
  int count, i, ii;
  int dum;
  int dtproc, iface, paramct, dpdsc, fval;
  int dtype;
  int ast;
  int argt;
  SST *sp;
  int param_dummy;
  int return_value, isarray, save_func_arrinfo;
  char *kwd_str; /* where make_kwd_str saves the string */
  int argt_count;
  int shaper;
  int new_ast;
  int psptr, msptr;
  int pass_pos;

  fix_proc_pointer_call(stktop, &list);
  return_value = 0;
  save_func_arrinfo = 0;
  SST_CVLENP(stktop, 0);
  ast = astb.i0; /* initialize just in case error occurs */
  kwd_str = NULL;
  dtype = A_DTYPEG(astb.i0);
  shaper = 0;
  pass_pos = -1;
  if (SST_IDG(stktop) != S_LVALUE) {
    func_sptr = SST_SYMG(stktop);
    callee = mk_id(func_sptr);
  } else {
    func_sptr = SST_LSYMG(stktop);
    if (!is_procedure_ptr(func_sptr)) {
      /* error must have occurred */
      goto exit_;
    }
    callee = SST_ASTG(stktop);
  }
  dtype = DTYPEG(func_sptr);
#if DEBUG
  assert(DTY(dtype) == TY_PTR, "ptrfunc_call, expected TY_PTR dtype", func_sptr,
         4);
#endif
  dtproc = DTY(dtype + 1);
#if DEBUG
  assert(DTY(dtproc) == TY_PROC, "ptrfunc_call, expected TY_PROC dtype",
         func_sptr, 4);
#endif
  dtype = DTY(dtproc + 1);
  iface = DTY(dtproc + 2);
  paramct = DTY(dtproc + 3);
  dpdsc = DTY(dtproc + 4);
  fval = DTY(dtproc + 5);
  if (iface) {
    FUNCP(iface, 1); /* mark sptr as a function */
  }
  if (iface != func_sptr && !paramct) {
    proc_arginfo(iface, &paramct, &dpdsc, NULL);
    DTY(dtproc + 3) = paramct;
    DTY(dtproc + 4) = dpdsc;
  }
  add_typroc(dtproc);
  shaper = 0;
  if (iface)
    isarray = is_array_dtype(DTYPEG(iface));
  else
    isarray = is_array_dtype(dtype);
  if (dpdsc)
    kwd_str = make_keyword_str(paramct, dpdsc);
  /* store function st in ERRSYM for error messages; used to be set only
   * for CHAR
   */
  SST_ERRSYMP(stktop, func_sptr);

  if (list == NULL)
    list = ITEM_END;
  count_actuals(list);
  count = carg.nent;
  argt_count = carg.nargt;

  init_byval();

  if (kwd_str) {
    if (chk_arguments(func_sptr, count, list, kwd_str, paramct, dpdsc, callee,
                      &pass_pos))
      goto exit_;
    count_formal_args(paramct, dpdsc);
    argt_count = carg.nargt;
    if (!fval)
      fval = iface;
    /* for ST_ENTRY, the data type info is set in the return value symbol */
    if (POINTERG(fval)) {
      /*
       * since the result of the function is a pointer, a pointer
       * temporary must be created.
       * Note that for an 'adjustable' return value, its size
       * may be dependent on the actual arguments.
       */
      set_descriptor_sc(sem.sc);
      if (isarray) {
        return_value = fval;
      } else {
        return_value = get_next_sym(SYMNAME(iface), "v");
        STYPEP(return_value, ST_VAR);
        SCP(return_value, SC_BASED);
        DTYPEP(return_value, dtype);
        DCLDP(return_value, 1);
        POINTERP(return_value, 1);
        if (DTYG(dtype) == TY_DERIVED && XBIT(58, 0x40000)) {
          F90POINTERP(return_value, 1);
        } else {
          get_static_descriptor(return_value);
          get_all_descriptors(return_value);
        }
      }
#ifdef CLASSG
      if (HCCSYMG(return_value) && !CLASSG(return_value))
        CLASSP(return_value, CLASSG(FVALG(func_sptr)));
#endif
      {
        return_value =
            gen_pointer_result(return_value, dpdsc, carg.nent, FALSE, iface);
        argt_count++;
        argt = mk_argt(argt_count); /* mk_argt stuffs away count */
        ARGT_ARG(argt, 0) = return_value;
        ii = 1;
        save_func_arrinfo = 1;
      }
      set_descriptor_sc(SC_LOCAL);
    } else if (ALLOCATTRG(fval)) {
      /*
       * result of the function is an allocatable, should be similiar
       * to a pointer
       */
      if (isarray) {
        fval_sptr = fval;
      } else {
        fval_sptr = get_next_sym(SYMNAME(iface), "v");
        STYPEP(fval_sptr, ST_VAR);
        SCP(fval_sptr, SC_BASED);
        DTYPEP(fval_sptr, dtype);
        DCLDP(fval_sptr, 1);
        set_descriptor_sc(sem.sc);
        get_static_descriptor(fval_sptr);
        get_all_descriptors(fval_sptr);
        set_descriptor_sc(SC_LOCAL);
      }
      return_value = gen_allocatable_result(fval_sptr, dpdsc, carg.nent,
                                            (DTYG(dtype) == TY_DERIVED), iface);
#ifdef CLASSG
      if (HCCSYMG(fval_sptr) && !CLASSG(fval_sptr))
        CLASSP(fval_sptr, CLASSG(FVALG(func_sptr)));
#endif
      argt_count++;
      argt = mk_argt(argt_count); /* mk_argt stuffs away count */
      ARGT_ARG(argt, 0) = return_value;
      ii = 1;

      add_p_dealloc_item(memsym_of_ast(return_value));
    } else if (allocatable_member(fval)) {
      if (ELEMENTALG(iface)) {
        int i;
        for (i = 0; i < argt_count; ++i) {
          shaper = A_SHAPEG(ARG_AST(i));
          if (shaper) {
            int dt = dtype_with_shape(dtype, shaper);
            fval_sptr = get_arr_temp(dt, FALSE, FALSE, FALSE);
            DTYPEP(fval_sptr, dt);
            STYPEP(fval_sptr, ST_ARRAY);
            break;
          }
        }
      }
      if (!shaper) {
        if (ADJARRG(fval)) {
          return_value = ref_entry(iface);
          return_value =
              gen_array_result(return_value, dpdsc, carg.nent, FALSE, iface);
          fval_sptr = A_SPTRG(return_value);
        } else {
          fval_sptr = get_next_sym(SYMNAME(func_sptr), "d");
          if (isarray) {
            STYPEP(fval_sptr, ST_ARRAY);
          } else {
            STYPEP(fval_sptr, ST_VAR);
          }
          DTYPEP(fval_sptr, dtype);
        }
      }

      SCP(fval_sptr, sem.sc);
      if (ASSUMSHPG(fval) || ASUMSZG(fval)) {
        set_descriptor_sc(sem.sc);
        get_static_descriptor(fval_sptr);
        get_all_descriptors(fval_sptr);
        set_descriptor_sc(SC_LOCAL);
      }
      init_derived_type(fval_sptr, 0, STD_PREV(0));
      argt_count++;
      argt = mk_argt(argt_count); /* mk_argt stuffs away count */
      return_value = mk_id(fval_sptr);
      ARGT_ARG(argt, 0) = return_value;
      ii = 1;
      add_p_dealloc_item(fval_sptr);
    } else if (isarray) {
      /*
       * since the result of the function is an array, a temporary
       * must be allocated at run-time even if its bounds are contant.
       * Note that for an 'adjustable' return value, its size
       * may be dependent on the actual arguments.
       */
      if (iface)
        return_value = ref_entry(iface);
      else
        return_value = fval;
      if (!ADJLENG(fval))
        return_value =
            gen_array_result(return_value, dpdsc, carg.nent, FALSE, iface);
      else
        return_value = gen_char_result(return_value, dpdsc, carg.nent);
      argt_count++;
      argt = mk_argt(argt_count); /* mk_argt stuffs away count */
      ARGT_ARG(argt, 0) = return_value;
      ii = 1;
      /*
       * have an array-valued function; save up information
       * which would allow substituting the result temp with
       * the LHS of an assignment.
       */
      save_func_arrinfo = 1;
    } else if (ADJLENG(fval)) {
      return_value = gen_char_result(fval, dpdsc, carg.nent);
      argt_count++;
      argt = mk_argt(argt_count); /* mk_argt stuffs away count */
      ARGT_ARG(argt, 0) = return_value;
      ii = 1;
    } else {
      argt = mk_argt(argt_count); /* mk_argt stuffs away count */
      ii = 0;
    }

    fval = gen_finalized_result(fval, func_sptr);

    for (i = 0; i < carg.nent; i++) {
      sp = ARG_STK(i);
      if (sp) {
        /* add to ARGT list, handling derived type arguments as
         * special case.
         */
        sptr1 = 0;
        if (SST_IDG(sp) == S_LVALUE)
          sptr1 = SST_LSYMG(sp);
        else if (SST_IDG(sp) == S_DERIVED || SST_IDG(sp) == S_IDENT)
          sptr1 = SST_SYMG(sp);
        else if (SST_IDG(sp) == S_SCONST) {
          (void)mkarg(sp, &dum);
          sptr1 = SST_SYMG(sp);
        }
        {
          param_dummy = inc_dummy_param(iface);

          if (is_iso_cloc(SST_ASTG(sp))) {
            if (find_byval_ref(func_sptr, param_dummy, 1) == PASS_BYVAL) {
              /* pass by val iso_c pointer to arg:
                 C_LOC(arg)   C_FUN_LOC(arg)
                 is plain old pass by reference
                 without type checking: get rid of the
                C_LOC:
               */
              new_ast = ARGT_ARG(A_ARGSG(SST_ASTG(sp)), 0);
              if (A_TYPEG(new_ast) == A_ID && (!TARGETG(A_SPTRG(new_ast))) &&
                  (!POINTERG(A_SPTRG(new_ast))))
                errwarn(468);

              SST_ASTP(sp, new_ast);
              SST_IDP(sp, S_EXPR);
              ARGT_ARG(argt, ii) = SST_ASTG(sp);
            } else {
              /* iso_c_loc by reference pointer to pointer */
              ARGT_ARG(argt, ii) = ARG_AST(i);
            }

          } else if (get_byval(func_sptr, param_dummy)) {
            /*  function arguments not processed by lowerilm */
            if (PASSBYVALG(param_dummy)) {
              if (OPTARGG(param_dummy)) {
                int assn = sem_tempify(sp);
                (void)add_stmt(assn);
                SST_ASTP(sp, A_DESTG(assn));
                byvalue_ref_arg(sp, &dum, OP_REF, func_sptr);
              } else if (!need_tmp_retval(iface, param_dummy)) {
                byvalue_ref_arg(sp, &dum, OP_BYVAL, iface);
              } else {
                byvalue_ref_arg(sp, &dum, OP_VAL, iface);
              }
            } else {
              byvalue_ref_arg(sp, &dum, OP_VAL, iface);
            }
            ARGT_ARG(argt, ii) = SST_ASTG(sp);
          } else if (pass_char_no_len(func_sptr, param_dummy)) {
            byvalue_ref_arg(sp, &dum, OP_REF, func_sptr);
            ARGT_ARG(argt, ii) = SST_ASTG(sp);
          } else {
            ARGT_ARG(argt, ii) = ARG_AST(i);
          }
          ii++;
        }
      } else if (i == pass_pos) {
        ARGT_ARG(argt, ii) = A_PARENTG(callee);
        ii++;
      } else {
        int npad;
        for (npad = ARG_AST(i); npad > 0; npad--) {
          ARGT_ARG(argt, ii) = astb.ptr0;
          ii++;
        }
      }
    }
    if (return_value) {
      /* return_value is symbol if result is of derived type;
       * otherwise, it's an ast.
       */
      dtype = DTYPEG(A_SPTRG(return_value));
      ast = mk_func_node(A_CALL, callee, argt_count, argt);
      sem.arrfn.call_std = add_stmt(ast);
      sem.arrfn.sptr = iface;
      if (save_func_arrinfo) {
        sem.arrfn.return_value = return_value;
        if (ALLOCG(A_SPTRG(return_value)))
          sem.arrfn.alloc_std = sem.alloc_std;
      }
      ast = return_value;
    } else {
      ast = mk_func_node(A_FUNC, callee, argt_count, argt);
    }
    if (ELEMENTALG(iface)) {
      int argc;
      for (argc = 0; argc < argt_count; ++argc) {
        /* Use first shaped argument */
        shaper = A_SHAPEG(ARGT_ARG(argt, argc));
        if (shaper)
          break;
      }
      if (shaper == 0) {
        shaper = mkshape(dtype);
      } else {
        dtype = dtype_with_shape(dtype, shaper);
        A_SHAPEP(ast, shaper);
      }
    } else {
      shaper = mkshape(dtype);
    }
    A_DTYPEP(ast, dtype);
    goto exit_;
  }
  ii = 0;
  /* before processing arguments, add derived type return values if needed */
  argt = mk_argt(argt_count); /* mk_argt stuffs away count */

  for (itemp = list; itemp != ITEM_END; itemp = itemp->next) {
    sp = itemp->t.stkp;
    if (SST_IDG(sp) == S_KEYWORD) {
      /* form is <ident> = <expression> */
      error(79, 3, gbl.lineno, scn.id.name + SST_CVALG(itemp->t.stkp), CNULL);
      itemp->t.sptr = 1;
      ARGT_ARG(argt, ii) = astb.i0;
      ii++;
      continue;
    }
    if (SST_IDG(sp) == S_TRIPLE) {
      /* form is e1:e2:e3 */
      error(76, 3, gbl.lineno, SYMNAME(func_sptr), CNULL);
      itemp->t.sptr = 1;
      ARGT_ARG(argt, ii) = astb.i0;
      ii++;
      continue;
    }
    if (SST_IDG(sp) == S_LABEL) {
      error(155, 3, gbl.lineno, "Illegal use of alternate return specifier",
            CNULL);
      ARGT_ARG(argt, ii) = astb.i0;
      ii++;
      continue;
    }
    /* check arguments and add to ARGT list, handling derived type
       arguments as special case */
    sptr1 = 0;
    if (SST_IDG(sp) == S_DERIVED || SST_IDG(sp) == S_IDENT)
      sptr1 = SST_SYMG(sp);
    else if (SST_IDG(sp) == S_LVALUE)
      sptr1 = SST_LSYMG(sp);
    else if (SST_IDG(sp) == S_SCONST) {
      (void)mkarg(sp, &dum);
      sptr1 = SST_SYMG(sp);
    }
    {
      /* form is <ident> or <expression> */
      param_dummy = inc_dummy_param(iface);
      /*  function arguments not processed bylowerilm */

      if ((A_TYPEG(SST_ASTG(sp)) == A_ID) &&
          is_iso_cptr(DTYPEG(A_SPTRG(SST_ASTG(sp))))) {
        if (find_byval_ref(iface, param_dummy, 1) == PASS_BYVAL) {
          /* iso cptr passed by value needs to transform into
             pass by value cptr->member : (pass the pointer
             sitting in cptr->member by value) */

          psptr = A_SPTRG(SST_ASTG(sp));
          msptr = DTY(DTYPEG(psptr) + 1);
          new_ast = mk_member(SST_ASTG(sp), mk_id(msptr), DTYPEG(msptr));
          SST_ASTP(sp, new_ast);
          SST_IDP(sp, S_EXPR);
          SST_DTYPEP(sp, DTYPEG(msptr));

          byvalue_ref_arg(sp, &dum, OP_VAL, iface);
          ARGT_ARG(argt, ii) = SST_ASTG(sp);
        } else {
          /* plain pass by ref */
          itemp->t.sptr = chkarg(sp, &dum);
          ARGT_ARG(argt, ii) = SST_ASTG(sp);
        }
      } else if (is_iso_cloc(SST_ASTG(sp))) {

        if (find_byval_ref(iface, param_dummy, 1) == PASS_BYVAL) {
          /* pass by val iso_c pointer to arg:
             C_LOC(arg)   C_FUN_LOC(arg)
             is plain old pass by reference
             without type checking: get rid of the c_LOC
           */
          new_ast = ARGT_ARG(A_ARGSG(SST_ASTG(sp)), 0);
          if (A_TYPEG(new_ast) == A_ID && (!TARGETG(A_SPTRG(new_ast))) &&
              (!POINTERG(A_SPTRG(new_ast))))
            errwarn(468);

          SST_ASTP(sp, new_ast);
          SST_IDP(sp, S_EXPR);
          ARGT_ARG(argt, ii) = SST_ASTG(sp);

        } else {
          /* iso_c_loc by reference: pointer to pointer */
          ARGT_ARG(argt, ii) = SST_ASTG(sp);
        }
      } else if (get_byval(iface, param_dummy)) {

        itemp->t.sptr = byvalue_ref_arg(sp, &dum, OP_VAL, iface);
        ARGT_ARG(argt, ii) = SST_ASTG(sp);
      } else if (pass_char_no_len(iface, param_dummy)) {
        itemp->t.sptr = byvalue_ref_arg(sp, &dum, OP_REF, iface);
        ARGT_ARG(argt, ii) = SST_ASTG(sp);

      } else {
        itemp->t.sptr = chkarg(sp, &dum);
        ARGT_ARG(argt, ii) = SST_ASTG(sp);
      }
      ii++;
    }
  }

  ast = mk_func_node(A_FUNC, callee, argt_count, argt);
  A_DTYPEP(ast, dtype);
  A_SHAPEP(ast, mkshape(dtype));
  if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR)
    error(89, 3, gbl.lineno, SYMNAME(func_sptr), CNULL);

exit_:
  SST_IDP(stktop, S_EXPR);
  SST_ASTP(stktop, ast);
  if (shaper)
    SST_SHAPEP(stktop, shaper);
  else
    SST_SHAPEP(stktop, A_SHAPEG(ast));
  SST_DTYPEP(stktop, dtype);
exit_2:
  if (kwd_str)
    FREE(kwd_str);

  return 1;
}

/*
 * add the proc data type to a list so that semfin can
 * adjust the PARAMCT and DPDSC values for functions
 * returning certain types.
 */
static void
add_typroc(int dt)
{
  int i;

  for (i = 0; i < sem.typroc_avail; i++) {
    if (sem.typroc_base[i] == dt)
      return;
  }
  sem.typroc_avail++;
  NEED(sem.typroc_avail, sem.typroc_base, int, sem.typroc_size,
       sem.typroc_avail + 50);
  sem.typroc_base[sem.typroc_avail - 1] = dt;
}

static void
count_actuals(ITEM *list)
{
  ITEM *itemp;
  SST *sp;
  int dum;

  carg.nargt = carg.nent = 0;
  for (itemp = list; itemp != ITEM_END; itemp = itemp->next) {
    sp = itemp->t.stkp;
    if (SST_IDG(sp) == S_KEYWORD)
      sp = SST_E3G(sp);
    /* adjust argument count, if derived type arguments are used as
       individual entities */
    if (SST_IDG(sp) == S_SCONST) {
      mkarg(sp, &dum); /* mkarg will assign to tmp- S_IDENT */
      carg.nargt++;
    } else
      carg.nargt++;
    carg.nent++;
  }
}

static void
count_formals(int sptr)
{
  count_formal_args(PARAMCTG(sptr), DPDSCG(sptr));
}

static void
count_formal_args(int paramct, int dpdsc)
{
  int *dscptr;
  int arg;
  int i;

  carg.nargt = carg.nent = paramct;
  dscptr = aux.dpdsc_base + dpdsc;
  for (i = paramct; i > 0; i--) {
    arg = *dscptr++;
    if (CLASSG(arg) && CCSYMG(arg) /*&& OPTARGG(arg)*/) {
      carg.nargt--;
      carg.nent--;
    }
    if (DESCARRAYG(arg) && NODESCG(arg) && DTY(DTYPEG(arg)) == TY_ARRAY &&
        NODESCG(arg)) {
      carg.nargt--;
      carg.nent--;
    }
  }
}

static int
fix_character_length(int dtype, int func_sptr)
{
  int dscptr, paramct, clen;
  if (DTY(dtype) != TY_CHAR
      && DTY(dtype) != TY_NCHAR
  )
    return dtype;

  /* we have a character datatype, replace any formal arguments in
   * the character length by their values, rewrite the length */
  dscptr = DPDSCG(func_sptr);
  paramct = PARAMCTG(func_sptr);
  ast_visit(1, 1);
  replace_arguments(dscptr, paramct);
  clen = ast_rewrite(DTY(dtype + 1));
  ast_unvisit();
  if (clen == DTY(dtype + 1))
    return dtype;
  /* character length has changed, create new character datatype */
  dtype = get_type(2, DTY(dtype), clen);
  return dtype;
} /* fix_character_length */

static int
gen_pointer_result(int array_value, int dscptr, int nactuals,
                   LOGICAL is_derived, int func_sptr)
{
  int o_dt;
  int dt;
  int arr_tmp;
  int pvar;

  o_dt = DTYPEG(array_value);
  if (DTY(o_dt) == TY_ARRAY) {
    int l;
    dt = dup_array_dtype(o_dt);
    l = fix_character_length(DTY(dt + 1), func_sptr);
    DTY(dt + 1) = l;
  } else {
    dt = fix_character_length(o_dt, func_sptr);
  }
  /*
   * Create a new pointer temporary with a new dtype record
   */
  if (is_derived) {
    arr_tmp = array_value;
    DTYPEP(arr_tmp, dt);
  } else {
    int ddt;
    arr_tmp = get_next_sym(SYMNAME(array_value), NULL);
    dup_sym(arr_tmp, stb.stg_base + array_value);
    DTYPEP(arr_tmp, dt);
    DESCRP(arr_tmp, 0);
    /*
     * set_descriptor_sc(sem.sc); already called in the caller
     */
    get_static_descriptor(arr_tmp);
    get_all_descriptors(arr_tmp);
    /* need to have different MIDNUM than arr_value */
    /* otherwise multiple declaration */
    pvar = sym_get_ptr(arr_tmp);
    MIDNUMP(arr_tmp, pvar);
    NODESCP(arr_tmp, 0);
    ddt = DDTG(dt);
    if ((DTY(dt) == TY_CHAR && dt != DT_DEFERCHAR) ||
        (DTY(dt) == TY_NCHAR && dt != DT_DEFERNCHAR)) {
      add_auto_len(arr_tmp, 0);
      if (CVLENG(arr_tmp))
        ERLYSPECP(CVLENG(arr_tmp), 1);
    }
  }
  if (gbl.internal > 1) {
    INTERNALP(arr_tmp, 1);
  } else {
    INTERNALP(arr_tmp, 0);
  }
  if (DTY(o_dt) == TY_ARRAY) {
    STYPEP(arr_tmp, ST_ARRAY);
    ALLOCP(arr_tmp, 1);
  } else
    STYPEP(arr_tmp, ST_VAR);
  SCOPEP(arr_tmp, stb.curr_scope);
  IGNOREP(arr_tmp, 0);
  SLNKP(arr_tmp, 0);
  SOCPTRP(arr_tmp, 0);
  SCP(arr_tmp, SC_BASED);
  ref_based_object(arr_tmp);

  return mk_id(arr_tmp);
}

static int
gen_allocatable_result(int array_value, int dscptr, int nactuals,
                       LOGICAL is_derived, int func_sptr)
{
  int o_dt;
  int dt;
  int arr_tmp;
  int pvar;
  int astrslt;
  int astnull;
  int sptrnull;

  o_dt = DTYPEG(array_value);
  if (DTY(o_dt) == TY_ARRAY) {
    int l;
    dt = dup_array_dtype(o_dt);
    l = fix_character_length(DTY(dt + 1), func_sptr);
    DTY(dt + 1) = l;
  } else {
    dt = fix_character_length(o_dt, func_sptr);
  }
  /*
   * Create a new allocatable temporary with a new dtype record
   */
  arr_tmp = get_next_sym(SYMNAME(array_value), NULL);
  dup_sym(arr_tmp, stb.stg_base + array_value);
  DTYPEP(arr_tmp, dt);
  DESCRP(arr_tmp, 0);
  /*
   * Would like to call set_descriptor_sc() at the beginning
   * of func2_call() and restore at the end; however, there
   * are still semsym things that might need to be done to user
   * variables.  So, only call set_descriptor_sc() when we know
   * we are creating temps.
   */
  set_descriptor_sc(sem.sc);
  get_static_descriptor(arr_tmp);
  get_all_descriptors(arr_tmp);
  /* need to have different MIDNUM than arr_value */
  /* otherwise multiple declaration */
  pvar = sym_get_ptr(arr_tmp);
  MIDNUMP(arr_tmp, pvar);
  NODESCP(arr_tmp, 0);
  ALLOCATTRP(arr_tmp, 1);
  set_descriptor_sc(SC_LOCAL);
  if (DTY(o_dt) == TY_ARRAY) {
    STYPEP(arr_tmp, ST_ARRAY);
    ALLOCP(arr_tmp, 1);
  } else
    STYPEP(arr_tmp, ST_VAR);
  if (gbl.internal > 1) {
    INTERNALP(arr_tmp, 1);
  } else {
    INTERNALP(arr_tmp, 0);
  }
  SCOPEP(arr_tmp, stb.curr_scope);
  IGNOREP(arr_tmp, 0);
  SLNKP(arr_tmp, 0);
  SOCPTRP(arr_tmp, 0);
  SCP(arr_tmp, SC_BASED);
  astrslt = ref_based_object_sc(arr_tmp, sem.sc);
  ALLOCATTRP(arr_tmp, 1);
  astrslt = mk_id(arr_tmp);

  return astrslt;
}

/*
 * check whether an array descriptor has fixed bounds
 * and whether the bounds are 'small enough'
 */
static int
small_enough(ADSC *ad, int numdim)
{
  int i;
  ISZ_T size;
  size = 1;
  for (i = 0; i < numdim; ++i) {
    int l, u;
    ISZ_T lv, uv;
    l = AD_LWBD(ad, i);
    if (l && !A_ALIASG(l))
      return 0;
    lv = 1; /* default */
    if (l) {
      l = A_ALIASG(l);
      assert(A_TYPEG(l) == A_CNST,
             "small_enough: expecting constant lower bound", l, 4);
      lv = get_isz_cval(A_SPTRG(l));
    }
    u = AD_UPBD(ad, i);
    if (!u || !A_ALIASG(u))
      return 0; /* not fixed size, or assumed-size */
    u = A_ALIASG(u);
    assert(A_TYPEG(u) == A_CNST, "small_enough: expecting constant upper bound",
           l, 4);
    uv = get_isz_cval(A_SPTRG(u));
    size *= (uv - lv + 1);
    if (size > 1000)
      return 0;
  }
  return 1;
} /* small_enough */

static int
gen_array_result(int array_value, int dscptr, int nactuals, LOGICAL is_derived,
                 int callee)
{
  int numdim;
  int o_dt;
  int dt;
  int arr_tmp;
  int ii;
  ADSC *ad;

  o_dt = DTYPEG(array_value);
  ad = AD_DPTR(o_dt);
  numdim = AD_NUMDIM(ad);
  /*
   * 0.  Check whether the return array size is fixed size and
   *     small enough to simply use a local array
   */
  if (small_enough(ad, numdim)) {
    /* use same name, etc. */
    arr_tmp = get_next_sym(SYMNAME(array_value), NULL);
    dup_sym(arr_tmp, stb.stg_base + array_value);
    NODESCP(arr_tmp, 0);
    DESCRP(arr_tmp, 0);
    ARGP(arr_tmp, 1);
    STYPEP(arr_tmp, ST_ARRAY);
    SCOPEP(arr_tmp, stb.curr_scope);
    IGNOREP(arr_tmp, 0);
    DTYPEP(arr_tmp, o_dt);
    SLNKP(arr_tmp, 0);
    if (gbl.internal > 1) {
      INTERNALP(arr_tmp, 1);
    } else {
      INTERNALP(arr_tmp, 0);
    }
    SCP(arr_tmp, sem.sc);
    return mk_id(arr_tmp);
  }
  /*
   * 1.  Create an allocatable temporary with a deferred-shape dtype
   *     using the sem.arrdim data structure.
   */
  sem.arrdim.ndefer = sem.arrdim.ndim = numdim;
  for (ii = 0; ii < numdim; ii++)
    sem.bounds[ii].lowtype = S_NULL;
  dt = mk_arrdsc();
  DTY(dt + 1) = DTY(o_dt + 1);

  if (is_derived)
    arr_tmp = array_value;
  else {
    arr_tmp = get_next_sym(SYMNAME(array_value), NULL);
    dup_sym(arr_tmp, stb.stg_base + array_value);
    NODESCP(arr_tmp, 0);
    DESCRP(arr_tmp, 0);
    PARAMCTP(arr_tmp, 0);
  }

  ARGP(arr_tmp, 1);
  STYPEP(arr_tmp, ST_ARRAY);
  SCOPEP(arr_tmp, stb.curr_scope);
  IGNOREP(arr_tmp, 0);
  DTYPEP(arr_tmp, dt);
  SLNKP(arr_tmp, 0);
  if (gbl.internal > 1) {
    INTERNALP(arr_tmp, 1);
  } else {
    INTERNALP(arr_tmp, 0);
  }
  SCP(arr_tmp, SC_BASED);
  ALLOCP(arr_tmp, 1);
  HCCSYMP(arr_tmp, 1);
  ref_based_object_sc(arr_tmp, sem.sc);

  /*
   * 2.  Generate the assignments to the bounds temporaries
   *     of the array temp and allocate it.
   * 2a. The values of the temporaries may depend on the actual arguments
   *     (e.g., a specification expression may refer to a formal); therefore,
   *     the 'formals' are replaced with the actuals.
   * 2b. If the current context is an internal procedure whose host is a
   *     module subroutine and the function called is also internal. The
   *     values of the bounds temps may depend on the dummy arguments of
   *     the host.  At this point, there are two symbol table entries for
   *     the host:
   *     1) ST_ENTRY and this is the parent scope of the current internal
   *        routine
   *     2) ST_PROC since the host is within a module -- recall that when a
   *        module is compiled, two syms are created for the module routine:
   *        an ST_PROC representing the routine's interface and an ST_ENTRY
   *        for when the body of the routine is actually compiled.
   *     These sym entries are distinct and each will have their own sym
   *     entries for their dummy arguments.  If there are bounds declarations
   *     in any array formal or result which refer to a host dummy, the
   *     corresponding sym entry for the dummy is the ST_PROC.  When the
   *     callee is invoked, the host dummy is in scope of the ST_ENTRY.
   *     Consequently, the bounds values refer to the incorrect instance of
   *     the host dummy.  The ASTs of the ST_PROC's host dummies referenced
   *     in the bounds computations must be replaced with the ASTs of the
   *     corresponding ST_ENTRY's host host dummies.
   */
  ad = AD_DPTR(o_dt);
  if (AD_ADJARR(ad)) {
    precompute_arg_intrin(dscptr, nactuals);
    precompute_args(dscptr, nactuals);
  }
  ast_visit(1, 1);
  if (gbl.currmod != 0 && gbl.internal > 1 && callee && INTERNALG(callee)) {
    /*
     * In an internal procedure whose host is a module routine and the
     * called function is also internal.
     */
    int host = SCOPEG(gbl.currsub); /* module routine (probably an ST_ALIAS) */
    /*
     * if sem.modhost_proc is non-zero, the host's ST_PROC & ST_ENTRY were
     * already discovered
     */
    if (sem.modhost_proc == 0) {
      /* starting with the first entry in the hash list, find the ST_PROC*/
      sem.modhost_proc = get_symtype(ST_PROC, first_hash(host));
      if (sem.modhost_proc != 0) {
        /*
         * if ST_PROC found, now find the ST_ENTRY - it will follow the ST_PROC
         * so do not have start over at first_hash(host).
         */
        sem.modhost_entry = get_symtype(ST_ENTRY, HASHLKG(sem.modhost_proc));
        if (sem.modhost_entry == 0)
          sem.modhost_proc = 0;
      }
    }
    if (sem.modhost_entry != 0) {
      /*
       * scan the ST_PROC's and ST_ENTRY's arguments and replace the
       * ASTs of the ST_PROC's args with the ASTs of the ST_ENTRY's args.
       */
      int i;
      for (i = PARAMCTG(sem.modhost_proc); i > 0; i--) {
        int old = aux.dpdsc_base[DPDSCG(sem.modhost_proc) + i - 1];
        int new = aux.dpdsc_base[DPDSCG(sem.modhost_entry) + i - 1];
        ast_replace(mk_id(old), mk_id(new));
      }
    }
  }
  replace_arguments(dscptr, nactuals);
  /*
   * 3.  Rewrite the bounds expressions of the original
   *     declaration of the function.  These values become
   *     the bounds expressions of the array temp and are
   *     stored in the sem.bounds data structure.
   *     Reset the sem.arrdim fields of (1) since
   *     precompute_arg_intrin() could cause them to be set
   *     for another context
   */
  sem.arrdim.ndefer = sem.arrdim.ndim = numdim;
  for (ii = 0; ii < numdim; ii++) {
    sem.bounds[ii].lowtype = S_NULL;
    if (AD_LWBD(ad, ii)) {
      replace_formal_triples(AD_LWBD(ad, ii), dscptr, nactuals);
      sem.bounds[ii].lwast = ast_rewrite((int)AD_LWBD(ad, ii));
    } else {
      sem.bounds[ii].lwast = astb.bnd.one;
    }
    replace_formal_triples(AD_UPBD(ad, ii), dscptr, nactuals);
    sem.bounds[ii].upast = ast_rewrite((int)AD_UPBD(ad, ii));
  }
  ast_unvisit();
  /*
   * 4.  assign values to the bounds temporaries and
   *     allocate the array; the utility routine also
   *     saves enough information so that the array
   *     temporary can be deallocated.
   */
  gen_allocate_array(arr_tmp);
  return mk_id(arr_tmp);
}

static int
gen_char_result(int fval, int dscptr, int nactuals)
{
  int dt, edt;
  int ctemp;
  int len;

  dt = DTYPEG(fval);
  edt = dt;
  if (DTY(dt) == TY_ARRAY)
    edt = DTY(dt + 1);
  ast_visit(1, 1);
  replace_arguments(dscptr, nactuals);
  len = ast_rewrite(DTY(edt + 1));
  ast_unvisit();
  if (A_TYPEG(len) == A_INTR && A_OPTYPEG(len) == I_LEN) {
    int aaa;
    aaa = ARGT_ARG(A_ARGSG(len), 0);
    if (A_TYPEG(aaa) == A_INTR && A_OPTYPEG(aaa) == I_TRIM) {
      len = ast_intr(I_LEN_TRIM, astb.bnd.dtype, 1, ARGT_ARG(A_ARGSG(aaa), 0));
    }
  }
  if (len != DTY(edt + 1)) {
    edt = get_type(2, TY_CHAR, len);
    if (DTY(dt) != TY_ARRAY)
      dt = edt;
    else {
      dt = dup_array_dtype(dt);
      DTY(dt + 1) = edt;
    }
  }
  ctemp = get_ch_temp(dt);
  return mk_id(ctemp);
}

static void
precompute_arg_intrin(int dscptr, int nactuals)
{
  int numdim;
  int ii;
  int dtype;

  for (ii = 0; ii < nactuals; ii++) {
    int arg, tmp, assn;
    if (!ARG_STK(ii))
      continue;
    arg = ARG_AST(ii);
    if (A_TYPEG(arg) == A_INTR) {
      dtype = A_DTYPEG(arg);
      if (DTY(dtype) == TY_ARRAY) {
        int shape;
        shape = A_SHAPEG(arg);
        if (shape) {
          if (SHD_NDIM(shape) != ADD_NUMDIM(dtype)) {
            tmp = get_shape_arr_temp(arg);
          } else {
            ADSC *ad;
            ad = AD_DPTR(dtype);
            if (AD_DEFER(ad) || AD_ADJARR(ad) || AD_NOBOUNDS(ad)) {
              tmp = get_shape_arr_temp(arg);
            } else
              tmp = get_arr_temp(dtype, FALSE, TRUE, FALSE);
          }
        } else
          tmp = get_arr_temp(dtype, FALSE, TRUE, FALSE);
      } else {
        dtype = get_temp_dtype(dtype, arg);
        tmp = get_temp(dtype);
      }
      assn = mk_assn_stmt(mk_id(tmp), arg, dtype);
      (void)add_stmt(assn);
      ARG_AST(ii) = A_DESTG(assn);
      SST_ASTP(ARG_STK(ii), ARG_AST(ii));
    }
  }
}

static void
precompute_args(int dscptr, int nactuals)
{
  int numdim;
  int ii;

  for (ii = 0; ii < nactuals; ii++) {
    int arg, dtype, assn;
    if (!ARG_STK(ii))
      continue;
    arg = ARG_AST(ii);
    if (!A_CALLFGG(arg))
      continue;
    dtype = A_DTYPEG(arg);
    if (!DT_ISSCALAR(dtype) && DTY(dtype) != TY_DERIVED)
      continue;
    assn = sem_tempify(ARG_STK(ii));
    (void)add_stmt(assn);
    ARG_AST(ii) = A_DESTG(assn);
    SST_ASTP(ARG_STK(ii), ARG_AST(ii));
  }
}

static void
rewrite_triples(int ast_subscr, int dscptr, int nactuals)
{
  int numdim;
  int i, j;
  int sptr_actual;
  int ast_actual = A_LOPG(ast_subscr);

  if (A_TYPEG(ast_actual) == A_ID) {
    sptr_actual = A_SPTRG(ast_actual);
  } else if (A_TYPEG(ast_actual) == A_MEM) {
    sptr_actual = A_SPTRG(A_MEMG(ast_actual));
  } else {
    return;
  }

  for (i = 0; i < nactuals; i++) {
    if (ARG_STK(i)) {
      int sptr_arg;
      int arg = ARG_AST(i);
      if (A_TYPEG(arg) == A_ID) {
        sptr_arg = A_SPTRG(arg);
      } else if (A_TYPEG(arg) == A_MEM) {
        sptr_arg = A_SPTRG(A_MEMG(arg));
      } else {
        continue;
      }
      if (sptr_arg == sptr_actual) {
        int asd = A_ASDG(ast_subscr);
        int ndim = ASD_NDIM(asd);
        int dt_formal = DTYPEG(aux.dpdsc_base[dscptr + i]);
        ADSC *ad_formal = AD_DPTR(dt_formal);
        int changed = FALSE;
        for (j = 0; j < ndim; j++) {
          int sub = ASD_SUBS(asd, j);
          if (A_TYPEG(sub) == A_TRIPLE &&
              AD_LWBD(ad_formal, j) == A_LBDG(sub) &&
              AD_UPBD(ad_formal, j) == A_UPBDG(sub)) {
            /* the triple is from the dummy arg, replace it */
            ADSC *ad_actual = AD_DPTR(DTYPEG(sptr_actual));
            int triple = mk_triple(AD_LWBD(ad_actual, j), AD_UPBD(ad_actual, j),
                                   AD_EXTNTAST(ad_actual, j));
            ast_replace(sub, triple);
          }
        }
      }
    }
  }
}

/*
 * A formal array can be subscripted in a specification expression;
 * when this occurs, need to check if the corresponding actual argument is
 * an array section.   The original processing can create something like:
 *    act(1:10)(1)
 * where the formal appears as formal(1) is some expression and the actual
 * argument is act(1:10).  Eventually, the illegal subscripting could  lead
 * to an ICE.
 */
static void
rewrite_subscr(int ast_subscr, int dscptr, int nactuals)
{
  int ast;
  int sptr;
  int arr, rpl;
  int flg;
  int i;
  int actarr;
  int asd, numdim;
  int subs[7]; /* maximum number of dimensions */
  int triple;
  int subscr;

  arr = A_LOPG(ast_subscr);
  if (A_TYPEG(arr) != A_ID)
    return;
  /*
   * Make sure what's being subscripted is a formal array which is being
   * replaced by some interesting array expression ...
   * is
   */
  rpl = A_REPLG(arr);
  if (!rpl)
    /* not being replaced */
    return;
  sptr = A_SPTRG(arr);
  if (STYPEG(sptr) != ST_ARRAY && SCG(sptr) != SC_DUMMY)
    return;
  flg = 0;
  for (i = 0; i < nactuals; i++) {
    if (sptr == aux.dpdsc_base[dscptr + i]) {
      /* is a formal argument of the called routine */
      flg = 1;
      break;
    }
  }
  if (!flg)
    /* not a formal array argument */
    return;

  if (A_TYPEG(rpl) != A_SUBSCR)
    /* the replacing expression is not being subscripted */
    return;

  /*
   *+++++++++++++++++  WARNING  +++++++++++++++++
   * only allow a single subscript of the formal for now. This covers
   * the bug in f15222, but eventually, this will need to be generalized.
   */
  asd = A_ASDG(ast_subscr);
  if (ASD_NDIM(asd) != 1)
    return;
  subscr = ASD_SUBS(asd, 0);

  actarr = A_LOPG(rpl);
  if (A_TYPEG(actarr) != A_ID)
    /* the actual arg being subscripted is not a simple array */
    return;

  asd = A_ASDG(rpl);
  numdim = ASD_NDIM(asd);
  flg = 0;
  for (i = 0; i < numdim; i++) {
    subs[i] = ASD_SUBS(asd, i);
    if (A_TYPEG(subs[i]) == A_TRIPLE) {
      flg = 1;
      triple = i;
    }
  }
  if (!flg) {
    /*
     * strictly speaking, this is an error that should have already
     * been caught since the formal is subscripted, and the actual
     * argument which is subscripted is not array-valued!
     */
    return;
  }
  subs[triple] = subscr;
  /*
   * create a new subscripted reference where the subscript expression
   * of the formal is folded into the subscript expression of the
   * actual argument.  The new subscripted references replaces the
   * current subscripted reference of the formal.
   */
  ast = mk_subscr(actarr, subs, numdim, A_DTYPEG(ast_subscr));
  ast_replace(ast_subscr, ast);
}

static void
replace_formal_triples(int ast, int dscptr, int nactuals)
{
  int cnt;
  int argt;
  int i;

  switch (A_TYPEG(ast)) {
  case A_BINOP:
    replace_formal_triples(A_LOPG(ast), dscptr, nactuals);
    replace_formal_triples(A_ROPG(ast), dscptr, nactuals);
    break;
  case A_UNOP:
  case A_PAREN:
  case A_CONV:
    replace_formal_triples(A_LOPG(ast), dscptr, nactuals);
    break;
  case A_INTR:
    cnt = A_ARGCNTG(ast);
    argt = A_ARGSG(ast);
    for (i = 0; i < cnt; i++) {
      /* watch for optional args */
      if (ARGT_ARG(argt, i) != 0) {
        replace_formal_triples(ARGT_ARG(argt, i), dscptr, nactuals);
      }
    }
    break;
  case A_SUBSCR:
    rewrite_triples(ast, dscptr, nactuals);
    rewrite_subscr(ast, dscptr, nactuals);
    break;
  default:
    ast_visit(ast, 1);
  }
}

/*
 * Substitute the formal arguments with the actual arguments.
 * Also, the appearance of formal arguments in descriptors need to
 * be replaced.
 */
static void
replace_arguments(int dscptr, int nactuals)
{
  int numdim;
  int ii;

  for (ii = 0; ii < nactuals; ii++) {
    if (ARG_STK(ii)) {
      int formal, formalid, arg, argid, astmem;
      formalid = aux.dpdsc_base[dscptr + ii];
      formal = mk_id(formalid);
      arg = ARG_AST(ii);
      ast_replace(formal, arg); /*formal <- actual*/
      argid = 0;
      if (A_TYPEG(arg) == A_ID) {
        argid = A_SPTRG(arg);
        astmem = 0;
      } else if (A_TYPEG(arg) == A_MEM) {
        argid = A_SPTRG(A_MEMG(arg));
        astmem = arg;
      }
      if (argid && formalid) {
        /* see if we should also replace any SDSC references
         * in the bounds, such as might come from translated
         * LBOUND(a,1) refs */
        if (SDSCG(formalid)) {
          formal = mk_id(SDSCG(formalid));
          if (!SDSCG(argid)) {
            get_static_descriptor(argid);
            get_all_descriptors(argid);
          }
          arg = check_member(astmem, mk_id(SDSCG(argid)));
          ast_replace(formal, arg);
        }
      }
    }
  }
}

static int
get_tbp(int sptr)
{
  /* Get a type bound procedure. Assume that sptr points to a user
   * defined type bound procedure. We then mangle it with a $tbp suffix.
   * This returns the sptr of the mangled type bound procedure (binding
   * name).
   */

  int len;
  char *name;

  if (STYPEG(sptr) != ST_PROC) {
    /* If we get here with a symbol that isn't a procedure, don't create
     * a new ...$tbp symbol that'll never be used.
     */
    return sptr;
  }

  name = SYMNAME(sptr);
  len = strlen(name);
  if (len > 4 && strcmp("$tbp", name + (len - 4)) == 0) {
    return sptr;
  }
  return getsymf("%s$tbp", name);
}

int
get_tbp_argno(int sptr, int dty)
{
  if (dty <= 0)
    dty = TBPLNKG(sptr);
  if (dty > 0 && VTOFFG(sptr) != 0) {
    int mem, imp = get_implementation(dty, sptr, 0, &mem), first = imp;
    while (imp > NOSYM) {
      int paramct, dpdsc, bind;
      assert(mem > NOSYM, "get_tbp_argno: bad mem sptr", sptr, 3);
      /* set bind to VTABLEG(mem) if bind is a generic type bound procedure */
      bind = STYPEG(sptr) == ST_PROC ? BINDG(mem) : VTABLEG(mem);
      if (PASSG(mem) <= NOSYM && !NOPASSG(mem) && INVOBJG(bind) > 0)
        return INVOBJG(bind);
      proc_arginfo(imp, &paramct, &dpdsc, 0);
      if (dpdsc > 0) {
        /* found what must be the implementation */
        int invobj = find_dummy_position(imp, PASSG(mem));
        if (invobj == 0) {
          if (PASSG(mem) > NOSYM) {
            char *name = SYMNAME(sptr), *name2 = name;
            int len = strlen(name);
            if (len > 4 && strcmp("$tbp", name + (len - 4)) == 0) {
              name2 = getitem(0, len + 1);
              strncpy(name2, name, len - 4);
            }
            error(155, 3, gbl.lineno,
                  "PASS arguments for type bound procedure "
                  "must have same name and position as overridden type bound "
                  "procedure",
                  name2);
          } else if (!NOPASSG(mem)) {
            invobj = 1; /* when no PASS or NOPASS, pass in the first position */
          }
        }
        if (invobj > 0 && STYPEG(sptr) == ST_PROC)
          INVOBJP(sptr, invobj);
        return invobj;
      }
      /* Try next hash link before giving up */
      get_next_hash_link(imp, 0 /* magic code to clear name's VISIT flags */);
      imp = get_next_hash_link(imp, 1 /* magic code, STYPE must match */);
      if (imp > NOSYM && test_scope(imp) != 0)
        imp = 0;
    }

    if (first <= NOSYM)
      first = sptr;
    error(155, 3, gbl.lineno,
          "Type bound procedure must be a module procedure "
          "or an external procedure with an explicit interface - ",
          SYMNAME(first));
  }
  return 0;
}

int
get_generic_member(int dtype, int sptr)
{

  /* This function is used to find the generic type bound procedure member
   * for a given dtype by matching the sptr with a member's VTABLE entry.
   * This function is also used in finding the type bound procedure
   * member with a given implementation (see chk_arguments() in
   * semfunc2.c).
   */

  int tag, mem;

  if (!dtype || DTY(dtype) != TY_DERIVED)
    return 0;

  for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
    if (CLASSG(mem) && VTABLEG(mem) && BINDG(mem) &&
        strcmp(SYMNAME(sptr), SYMNAME(VTABLEG(mem))) == 0) {
      return mem;
    }
  }

  tag = DTY(dtype + 3);
  if (PARENTG(tag)) {
    mem = get_generic_member(DTYPEG(PARENTG(tag)), sptr);
  }

  return (mem > NOSYM) ? mem : 0;
}

int
get_generic_member2(int dtype, int sptr, int argcnt, int *argno)
{

  /* Similar to get_generic_member() above, except it assumes sptr is the
   * generic type bound procedure symbol (i.e., has a $tbpg suffix).
   */
  int tag, mem, candidate, exact_match;

  if (!dtype || DTY(dtype) != TY_DERIVED)
    return 0;
  if (argno)
    *argno = 0;
  candidate = exact_match = 0;
  for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
    if (CLASSG(mem) && VTABLEG(mem) && BINDG(mem) &&
        strcmp(SYMNAME(sptr), SYMNAME(BINDG(mem))) == 0) {
      if (argcnt) {
        int mem2, func;
        mem2 = 0;
        func = get_implementation(dtype, VTABLEG(mem), 0, &mem2);
        if (mem2) {
          int i, paramct, dpdsc, reqargs, optargs, arg2, pass_arg;
          proc_arginfo(func, &paramct, &dpdsc, NULL);
          for (pass_arg = reqargs = optargs = i = 0; i < paramct; ++i) {
            arg2 = aux.dpdsc_base[dpdsc + i];
            if (OPTARGG(arg2)) {
              ++optargs;
            } else {
              ++reqargs;
            }
            if (PASSG(mem2) &&
                strcmp(SYMNAME(PASSG(mem2)), SYMNAME(arg2)) == 0) {
              pass_arg = arg2;
              if (argno)
                *argno = i + 1;
            } else if (i == 0 && !PASSG(mem2) && !NOPASSG(mem2)) {
              pass_arg = arg2;
              if (argno)
                *argno = i + 1;
            }
          }
          reqargs = (reqargs > 0) ? reqargs - (pass_arg > NOSYM) : 0;
          if (!optargs && argcnt == reqargs) {
            if (eq_dtype2(DTYPEG(pass_arg), dtype, 0))
              return mem;
            else if (eq_dtype2(DTYPEG(pass_arg), dtype, 1) && !exact_match)
              candidate = mem;
            else if (!pass_arg)
              candidate = mem;
          } else if (optargs && argcnt <= (optargs + reqargs)) {
            if (eq_dtype2(DTYPEG(pass_arg), dtype, 0)) {
              exact_match = 1;
              candidate = mem;
            } else if (eq_dtype2(DTYPEG(pass_arg), dtype, 1) && !exact_match)
              candidate = mem;
            else if (!pass_arg)
              candidate = mem;
          }
        }
      }
    }
  }
  tag = DTY(dtype + 3);
  if (candidate > NOSYM) {
    return candidate;
  }

  if (PARENTG(tag)) {
    mem = get_generic_member2(DTYPEG(PARENTG(tag)), sptr, argcnt, argno);
  }

  return (mem > NOSYM) ? mem : 0;
}

int
generic_tbp_has_pass_and_nopass(int dtype, int sptr)
{

  /* Checks for the special case where a generic type bound procedure has
   * two identical specific type bound procedures except one has nopass
   * and the other has pass set. Assumes that sptr is a generic tbp.
   */

  int found_nopass, found_pass;
  int tag, mem, rslt;

  if (STYPEG(sptr) != ST_USERGENERIC && STYPEG(sptr) != ST_OPERATOR)
    return 0;
  if (!dtype || DTY(dtype) != TY_DERIVED)
    return 0;
  found_nopass = found_pass = 0;
  for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
    if (CLASSG(mem) && VTABLEG(mem) && BINDG(mem) &&
        strcmp(SYMNAME(sptr), SYMNAME(BINDG(mem))) == 0) {
      if (NOPASSG(mem))
        found_nopass = 1;
      else
        found_pass = 1;
    }
  }

  tag = DTY(dtype + 3);
  if (PARENTG(tag)) {
    return generic_tbp_has_pass_and_nopass(DTYPEG(PARENTG(tag)), sptr);
  }

  return found_nopass && found_pass;
}

int
get_generic_tbp_pass_or_nopass(int dtype, int sptr, int flag)
{

  /* Get the generic tbp sptr from dtype. If flag is set, then
   * this routine will return the NOPASS version (if available),
   * else the PASS version (if available). It returns 0 if generic
   * tbp is not available or none available from the flag criteria.
   */
  int found_nopass, found_pass;
  int tag, mem, rslt;

  if (STYPEG(sptr) != ST_USERGENERIC && STYPEG(sptr) != ST_OPERATOR)
    return 0;
  if (!dtype || DTY(dtype) != TY_DERIVED)
    return 0;
  found_nopass = found_pass = 0;
  for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
    if (CLASSG(mem) && VTABLEG(mem) && BINDG(mem) &&
        strcmp(SYMNAME(sptr), SYMNAME(BINDG(mem))) == 0) {
      if (NOPASSG(mem))
        found_nopass = mem;
      else
        found_pass = mem;
    }
  }

  tag = DTY(dtype + 3);
  if (PARENTG(tag)) {
    return generic_tbp_has_pass_and_nopass(DTYPEG(PARENTG(tag)), sptr);
  }

  return (flag) ? found_nopass : found_pass;
}

int
get_specific_member(int dtype, int sptr)
{

  /* Similar to get_generic_member() except it returns the member of
   * the specific type bound procedure. This is needed when a user
   * operator has the same name (except for the leading and trailing
   * dot `.') as a specific type bound procedure.
   */

  int tag, mem, mem2;

  if (!dtype || DTY(dtype) != TY_DERIVED)
    return 0;
  mem2 = 0;
  for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
    if (CLASSG(mem) && VTABLEG(mem) && BINDG(mem) &&
        STYPEG(BINDG(mem)) != ST_OPERATOR &&
        STYPEG(BINDG(mem)) != ST_USERGENERIC &&
        strcmp(SYMNAME(sptr), SYMNAME(BINDG(mem))) == 0) {
      return mem;
    }
  }

  tag = DTY(dtype + 3);
  if (PARENTG(tag)) {
    mem = get_specific_member(DTYPEG(PARENTG(tag)), sptr);
  }

  return (mem > NOSYM) ? mem : 0;
}

static int
find_by_name_stype_arg(char *symname, int stype, int scope, int dtype, int inv,
                       int exact)
{
  int hash, hptr, len;
  int paramct, dpdsc, dtype2, arg;
  len = strlen(symname);
  HASH_ID(hash, symname, len);
  for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
    if (STYPEG(hptr) == stype && strcmp(SYMNAME(hptr), symname) == 0) {
      if (scope == 0 || scope == SCOPEG(hptr)) {
        if (!inv)
          return hptr;
        dpdsc = DPDSCG(hptr);
        arg = aux.dpdsc_base[dpdsc + (inv - 1)];
        dtype2 = DTYPEG(arg);
        if (eq_dtype2(dtype2, dtype, !exact && CLASSG(arg)) ||
            eq_dtype2(dtype, dtype2, !exact && CLASSG(arg)))
          return hptr;
      }
    }
  }
  return 0;
}

/** \brief For type bound procedures, find the implementation for the
 * type bound procedure binding name in dtype.
 *
 * If flag is set, then we check to see if we're accessing a PRIVATE
 * type bound procedure. If so, we issue an error message.
 *
 * \param dtype is the derived type record that we are searching.
 * \param orig_sptr is the symbol table pointer of the binding name of the
 *        type bound procedure to look up.
 * \param flag is set to check for accessing a PRIVATE type bound procedure.
 * \param memout if set, the function will store the type bound procedure
 *        symbol table pointer in this pointer argument.
 *
 * \return a symbol table pointer to the type bound procedure implementation;
 *         otherwise 0 (if not found).
 */
int
get_implementation(int dtype, int orig_sptr, int flag, int *memout)
{
  int sptr = orig_sptr;
  int mem, tag;
  int imp = 0, bind;
  int rslt = 0;
  int invobj = 0;
  const char *tbp_name, *suffix;
  int tbp_name_len;
  int my_mem;
  int inherited_imp = 0;
  int scope;
  SPTR tag_scope;
  static bool force_resolve_once = false;

  if (!memout)
    memout = &my_mem;
  *memout = 0;

  if (dtype > 0 && DTY(dtype) == TY_ARRAY)
    dtype = DTY(dtype + 1);
  if (dtype <= 0 || DTY(dtype) != TY_DERIVED)
    return 0;

  inherited_imp = 0;
  sptr = get_tbp(orig_sptr);
  tbp_name = SYMNAME(sptr);
  tbp_name_len = strlen(tbp_name);
  if ((suffix = strstr(tbp_name, "$tbp")))
    tbp_name_len = suffix - tbp_name;
  tag = DTY(dtype + 3);

  for(tag_scope = SCOPEG(tag); STYPEG(tag_scope) == ST_ALIAS;) {
    tag_scope = SYMLKG(tag_scope);
  }
  if (sem.which_pass > 0 && STYPEG(tag_scope) != ST_MODULE &&
      !force_resolve_once) {
    /* We have a derived type that's defined inside a procedure. We
     * need to force a resolution on the type bound procedures since they
     * do not normally get resolved until we see an ENDMODULE statement
     * (which would not necessarily apply in this case).
     *
     * Because queue_tbp() might also call get_implementation(), we need to
     * use the "force_resolve_once" variable to make sure queue_tbp() is
     * only called once with TBP_FORCE_RESOLVED.
     */
    force_resolve_once = true;
    queue_tbp(0, 0, 0, 0, TBP_FORCE_RESOLVE);
    force_resolve_once = false;
  }

  if (PARENTG(tag)) {
    imp = get_implementation(DTYPEG(PARENTG(tag)), sptr, 0, memout);
    if (imp) {
      bind = BINDG(*memout);
      invobj = INVOBJG(bind);
      inherited_imp = imp;
    }
  }
  for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
    bind = BINDG(mem);
    if (bind > NOSYM && CCSYMG(mem) && CLASSG(mem) && VTABLEG(mem)) {
      const char *bind_name = SYMNAME(bind);
      int bind_name_len = strlen(bind_name);
      if ((suffix = strstr(bind_name, "$tbp")))
        bind_name_len = suffix - bind_name;
      if (bind_name_len == tbp_name_len &&
          memcmp(tbp_name, bind_name, bind_name_len) == 0) {
        imp = IFACEG(mem) ? IFACEG(mem) : VTABLEG(mem);
        invobj = INVOBJG(bind);
        *memout = mem;
        break;
      }
    }
  }

  if (!imp)
    return 0;

  /*for submod, it needs to make comparison again with gbl.currsub, as
    submod's scope is 0 which doesn't equal to the proc defined in
    parent mod with scope to it's parent mod
  */
  if (flag && PRIVATEG(*memout) && SCOPEG(*memout) != gbl.currmod &&
      SCOPEG(*memout) != SCOPEG(gbl.currsub)) {
    error(155, 3, gbl.lineno, "cannot access PRIVATE type bound procedure",
          SYMNAME(orig_sptr));
  }

  if (!invobj && !NOPASSG(*memout)) {
    invobj = 1;
    bind = BINDG(*memout);
    if (STYPEG(bind) == ST_PROC)
      INVOBJP(bind, invobj);
  }
  scope = DTY(dtype) == TY_DERIVED ? SCOPEG(DTY(dtype + 3)) : 0;

  if (scope != SCOPEG(SCOPEG(imp)) && imp != inherited_imp) {
/* If imp is declared in same scoping unit as dtype, don't
 * perform the additional checks below.
 */
    /* Perform the additional checks below if the dtype's
     * implementation is not inherited from a parent type and its
     * defined in another scope.
     */
    rslt =
        find_by_name_stype_arg(SYMNAME(imp), ST_PROC, scope, dtype, invobj, 1);
    if (!rslt) {
      rslt = find_by_name_stype_arg(SYMNAME(imp), ST_PROC, scope, dtype, invobj,
                                    0);
    }

    if (!rslt) {
      rslt = find_by_name_stype_arg(SYMNAME(imp), ST_PROC, 0, dtype, invobj, 1);
    }

    if (!rslt) {
      rslt = find_by_name_stype_arg(SYMNAME(imp), ST_PROC, 0, dtype, invobj, 0);
    }

    if (!rslt) {
      rslt = find_by_name_stype_arg(SYMNAME(imp), ST_PROC, 0, 0, invobj, 0);
    }

    if (!rslt) {
      rslt = find_by_name_stype_arg(SYMNAME(imp), ST_PROC, 0, 0, 0, 0);
    }
  }

  if (!rslt) {
    rslt = imp;
  }

  if (rslt != VTABLEG(mem)) {
    VTABLEP(mem, rslt);
    if (DTYPEG(rslt))
      DTYPEP(mem, DTYPEG(rslt));
  }

  return rslt;
}

/*---------------------------------------------------------------------*/

/** \brief Write ILMs to call a subroutine.
    \param stktop function to call
    \param list   arguments to pass to function
    \param flag   set if called from a generic resolution routine
 */
void
subr_call2(SST *stktop, ITEM *list, int flag)
{
  int sptr, sptr1, stype;
  ITEM *itemp;
  int count, alt_ret;
  int dum, i, ii, check_generic;
  int ast;
  int argt;
  SST *sp;
  int param_dummy;
  char *kwd_str; /* where make_kwd_str saves the string */
  int tbp_mem;
  int doif;

  tbp_mem = 0;
  ast = 0; /* initialize just in case error occurs */
  kwd_str = NULL;
  sptr = SST_SYMG(stktop);
  if (sptr > 0) {
    check_generic = 1;
  } else {
    sptr = -sptr;
    SST_SYMP(stktop, sptr);
    check_generic = 0;
  }
try_next_sptr:
  stype = STYPEG(sptr);
  if (stype == ST_ALIAS) {
    sptr = SYMLKG(sptr);
    stype = STYPEG(sptr);
  }
  get_next_hash_link(sptr, 0);
try_next_hash_link:

  init_byval();
  if (stype != ST_PROC) {
    if (stype == ST_PD) {
      ref_pd_subr(stktop, list);
      return;
    }
    if (stype == ST_USERGENERIC && check_generic) {
      if (CLASSG(sptr)) {
        sptr = generic_tbp_call(sptr, stktop, list, 0);
        goto do_call;
      }
      generic_call(sptr, stktop, list, 0);
      return;
    }
    if (stype == ST_INTRIN) {
      /* class subroutine intrinsic? */
      switch (INTASTG(sptr)) {
      case I_C_F_POINTER:
      case I_C_F_PROCPOINTER:
        ref_intrin_subr(stktop, list);
        return;
      default:
        break;
      }
    }
    if (IS_INTRINSIC(stype)) {
      /* check if intrinsic is frozen */
      if ((sptr = newsym(sptr)) == 0) {
        ast = 0;
        goto exit_;
      }
    } else if (stype == ST_IDENT) {
      if (SCG(sptr) != SC_LOCAL) {
        if (SCG(sptr) == SC_DUMMY) {
          /*
           *  this is a dummy procedure call, but may be a user
           *  error.
           */
          error(125, 1, gbl.lineno, SYMNAME(sptr), CNULL);
        } else if (SCG(sptr) != SC_NONE) {
          error(84, 3, gbl.lineno, SYMNAME(sptr),
                "- attempt to CALL a non-SUBROUTINE");
          ast = 0;
          goto exit_;
        } else
          error(84, 3, gbl.lineno, SYMNAME(sptr),
                "- attempt to CALL a FUNCTION");
      }
    } else if (stype == ST_ENTRY) {
      int sptr2;
      if (GSAMEG(sptr) && check_generic) {
        if (CLASSG(sptr)) {
          sptr = generic_tbp_call(sptr, stktop, list, 0);
          goto do_call;
        }
        generic_call(GSAMEG(sptr), stktop, list, 0);
        return;
      }
      if (flg.recursive || RECURG(sptr)) {
        if (gbl.rutype != RU_SUBR) {
          error(84, 3, gbl.lineno, SYMNAME(sptr),
                "- attempt to CALL a non-SUBROUTINE");
          ast = 0;
          goto exit_;
        }
        if (DPDSCG(sptr))
          kwd_str = make_kwd_str(sptr);
        goto do_call;
      }
      sptr2 = findByNameStypeScope(SYMNAME(sptr), ST_PROC, 0);
      if (sptr2) {
        sptr = sptr2;
        goto try_next_sptr;
      }
      error(88, 3, gbl.lineno, SYMNAME(sptr), CNULL);
      ast = 0;
      goto exit_;
    } else if (stype != ST_UNKNOWN) {
      error(84, 3, gbl.lineno, SYMNAME(sptr),
            "- attempt to CALL a non-SUBROUTINE");
      ast = 0;
      goto exit_;
    } else {
      SCP(sptr, SC_NONE); /* <var ref> could have SET storage class */
    }
    /*
     * it's okay to make the symbol a procedure
     */
    STYPEP(sptr, ST_PROC);
    DTYPEP(sptr, 0);
    if (SCG(sptr) == SC_NONE)
      SCP(sptr, SC_EXTERN);
    if (SLNKG(sptr) == 0) {
      SLNKP(sptr, aux.list[ST_PROC]);
      aux.list[ST_PROC] = sptr;
    }
  } else { /* stype == ST_PROC */
    if (GSAMEG(sptr) && check_generic) {
      if (CLASSG(sptr)) {
        sptr = generic_tbp_call(sptr, stktop, list, 0);
        goto do_call;
      }
      generic_call(GSAMEG(sptr), stktop, list, 0);
      return;
    }
    if (DTYPEG(sptr) != 0 && (DCLDG(sptr) || FUNCG(sptr)))
      /* sptr is a function */
      error(84, 3, gbl.lineno, SYMNAME(sptr), "- attempt to CALL a FUNCTION");
    else
      /* first occurrence could have been
       * in an EXTERNAL statement in which case its dtype
       * was set due to the implicit handling.
       */
      DTYPEP(sptr, 0);
    if (DPDSCG(sptr))
      kwd_str = make_kwd_str(sptr);
    if (STYPEG(sptr) == ST_PROC && SLNKG(sptr) == 0) {
      SLNKP(sptr, aux.list[ST_PROC]);
      aux.list[ST_PROC] = sptr;
    }
  }

do_call:
  if (flg.xref)
    xrefput(sptr, 'r');

  alt_ret = 0;
  count_actuals(list);
  count = carg.nent;

  if (CLASSG(sptr)) {
    int sptr2;
    ast = SST_ASTG(stktop);
    switch (A_TYPEG(ast)) {
    case A_ID:
    case A_LABEL:
    case A_ENTRY:
    case A_SUBSCR:
    case A_SUBSTR:
    case A_MEM:
      sptr1 = memsym_of_ast(ast);
      sptr2 = pass_sym_of_ast(ast);
      if (STYPEG(BINDG(sptr1)) != ST_USERGENERIC) {
        sptr = BINDG(sptr1);
      } else {
        /* Replace the generic type bound procedure with the specific
         * type bound procedure.
         */
        int mem, dtype;
        dtype = DTYPEG(sptr2);
        if (DTY(dtype) == TY_ARRAY)
          dtype = DTY(dtype + 1);

        if (get_implementation(dtype, sptr, 0, &mem) == 0) {
          dtype = TBPLNKG(sptr);
        }

        if (get_implementation(dtype, sptr, 0, &mem) == 0) {
          char *name_cpy, *name;
          name_cpy = getitem(0, strlen(SYMNAME(sptr1)) + 1);
          strcpy(name_cpy, SYMNAME(sptr1));
          name = strchr(name_cpy, '$');
          if (name)
            *name = '\0';
          error(155, 3, gbl.lineno,
                "Could not resolve generic type bound "
                "procedure",
                name_cpy);
          sptr1 = 0;
          break;
        }
        ast = replace_memsym_of_ast(ast, mem);
        SST_ASTP(stktop, ast);
        sptr = BINDG(mem);
        sptr1 = mem;
      }
      break;
    default:
      if (check_generic && CLASSG(sptr) && list != ITEM_END &&
          SST_DTYPEG(list->t.stkp) &&
          !tk_match_arg(TBPLNKG(sptr), SST_DTYPEG(list->t.stkp), FALSE)) {
        /* FS20530: this handles the case where there is a TBP bind name and a
         * user
         * generic with the same name and sptr points to the TBP when what is
         * needed
         * is one of the generic implementations.
         */
        sptr1 = SST_SYMG(stktop);
        generic_call(sptr, stktop, list, 0);
        if (sptr1 != SST_SYMG(stktop)) {
          return;
        }
      }
      SST_SYMP(stktop, sptr1);
      sptr1 = 0;
    }

    if (sptr1 && (INVOBJG(sptr) || NOPASSG(sptr1))) {
      int imp, dty2;
      int dty, basedt, basedt2;
      int invobj, invobj2;
      int i;
      ITEM *itemp;

      dty = TBPLNKG(sptr);
      if (dty) {
        if (DTY(dty) == TY_ARRAY)
          basedt = DTY(dty + 1);
        else
          basedt = dty;
        imp = get_implementation(DTYPEG(sptr2), sptr, 0, NULL);
        if (imp) {
          invobj = get_tbp_argno(sptr, DTYPEG(sptr2));
        } else {
          invobj = get_tbp_argno(sptr, basedt);
        }
        if (invobj) {
          for (sp = 0, i = 1, itemp = list; i <= invobj && itemp != ITEM_END;
               ++i) {
            sp = itemp->t.stkp;
            itemp = itemp->next;
          }
          sptr1 = 0;
          if (SST_IDG(sp) == S_LVALUE || SST_IDG(sp) == S_EXPR)
            sptr1 = SST_LSYMG(sp);
          else if (SST_IDG(sp) == S_DERIVED || SST_IDG(sp) == S_IDENT)
            sptr1 = SST_SYMG(sp);
          else if (SST_IDG(sp) == S_SCONST) {
            (void)mkarg(sp, &dum);
            sptr1 = SST_SYMG(sp);
          }
          dty2 = DTYPEG(sptr1);
          if (DTY(dty2) == TY_ARRAY)
            basedt2 = DTY(dty2 + 1);
          else
            basedt2 = dty2;
          if (0 && !eq_dtype2(basedt, basedt2, 1)) { /* TBD */
            error(155, 3, gbl.lineno,
                  "Incompatible PASS argument in type "
                  "bound procedure call",
                  CNULL);
          } else {
            imp = get_implementation(basedt2, sptr, !flag, NULL);
            if (!imp) {
              error(155, 3, gbl.lineno,
                    "Incompatible PASS argument in type "
                    "bound procedure call",
                    CNULL);
            }
            invobj2 = get_tbp_argno(sptr, basedt2);
            if (invobj != invobj2) {
              error(155, 4, gbl.lineno,
                    "Type bound procedure "
                    "PASS arguments must have the same "
                    "name and position as PASS arguments in the overloaded "
                    "type bound procedure",
                    SYMNAME(imp));
            }

            set_pass_objects(invobj - 1, sptr1);

            CLASSP(imp, 1);
            sptr = imp;

            tbp_mem = ast;

            if (kwd_str)
              FREE(kwd_str);
            if (DPDSCG(sptr)) {
              kwd_str = make_kwd_str(sptr);
            }
          }
        } else if (NOPASSG(sptr1)) {
          sptr = sym_of_ast(ast);
          imp = get_implementation(basedt, BINDG(sptr1), !flag, NULL);
          sptr = imp;
          tbp_mem = ast;
          if (kwd_str)
            FREE(kwd_str);
          if (DPDSCG(sptr))
            kwd_str = make_kwd_str(sptr);
        }
      }
    }
  }

  if (!tbp_mem && sptr > NOSYM && !IS_PROC_DUMMYG(sptr) && TBPLNKG(sptr)) {
    int sym;
    do {
      sym = get_next_hash_link(sptr, 1);
    } while (sym && test_scope(SCOPEG(sym)) < 0);
    if (sym) {
      sptr = sym;
      if (kwd_str) {
        FREE(kwd_str);
        kwd_str = NULL;
      }
      goto try_next_hash_link;
    }
    if (!kwd_str) {
      for (itemp = list; itemp != ITEM_END; itemp = itemp->next) {
        sp = itemp->t.stkp;
        if (SST_IDG(sp) == S_KEYWORD) {
          kwd_str = make_kwd_str(sptr);
          break;
        }
      }
    }
  }

  /*
   * loop through the argument list to evaluate all of the arguments and
   * saving their values (ILM pointers);
   */
  if (kwd_str) {
    if (check_arguments(sptr, count, list, kwd_str))
      goto exit_;
    count_formals(sptr);
    count = carg.nent;
    argt = mk_argt(carg.nargt); /* mk_argt stuffs away count */
    ii = 0;
    for (i = 0; i < count; i++) {
      sp = ARG_STK(i);
      if (sp) {
        /* add to ARGT list, handling derived type arguments as
         * special case.
         */
        sptr1 = get_sym_from_sst_if_available(sp);
        {
          param_dummy = inc_dummy_param(sptr);

          if (!is_iso_cloc(SST_ASTG(sp)) && (A_TYPEG(SST_ASTG(sp)) != A_FUNC) &&
              is_iso_cptr(A_DTYPEG(SST_ASTG(sp)))) {
            /* rewrite iso cptr references,
               do not rewrite functions returning iso_cptr,
               do not rewrite iso c_loc
             */

            ARGT_ARG(argt, ii) = rewrite_cptr_references(SST_ASTG(sp));
          } else if (get_byval(sptr, param_dummy)
                    && PASSBYVALG(param_dummy)
                    && OPTARGG(param_dummy)) {
            int assn = sem_tempify(sp);
            (void)add_stmt(assn);
            SST_ASTP(sp, A_DESTG(assn));
            byvalue_ref_arg(sp, &dum, OP_REF, sptr);
            ARGT_ARG(argt, ii) = SST_ASTG(sp);
          } else if (pass_char_no_len(sptr, param_dummy)) {
            byvalue_ref_arg(sp, &dum, OP_REF, sptr);
            ARGT_ARG(argt, ii) = SST_ASTG(sp);
          } else if (INTENTG(param_dummy) == INTENT_IN &&
                     POINTERG(param_dummy) && !is_ptr_arg(sp)) {
            /* F2008: pass non-pointer actual arg for an
             *        INTENT(IN), POINTER formal arg */
            ARGT_ARG(argt, ii) = gen_and_assoc_tmp_ptr(sp, sem.last_std);
          } else {
            /* byval arguments done in lowerilm.c for  subroutines */
            ARGT_ARG(argt, ii) = ARG_AST(i);
          }
          ii++;
          if (sptr1 && STYPEG(sptr1) == ST_PROC && DPDSCG(sptr1) &&
              SLNKG(sptr1) == 0) {
            SLNKP(sptr1, aux.list[ST_PROC]);
            aux.list[ST_PROC] = sptr1;
          }
        }
      } else {
        int npad;
        for (npad = ARG_AST(i); npad > 0; npad--) {
          ARGT_ARG(argt, ii) = astb.ptr0;
          ii++;
        }
      }
    }
    if (tbp_mem) {
      int mem = memsym_of_ast(tbp_mem);
      if (STYPEG(mem) == ST_MEMBER && !strstr(SYMNAME(sptr), "$tbp")) {
        VTABLEP(mem, sptr);
      }
    }
    ast = mk_func_node(A_CALL, (tbp_mem) ? tbp_mem : mk_id(sptr), carg.nargt,
                       argt);
    goto exit_;
  }
  argt = mk_argt(carg.nargt); /* mk_argt stuffs away count */
  if (tbp_mem) {
    int mem = memsym_of_ast(tbp_mem);
    if (STYPEG(mem) == ST_MEMBER && !strstr(SYMNAME(sptr), "$tbp")) {
      VTABLEP(mem, sptr);
    }
  }
  ast =
      mk_func_node(A_CALL, (tbp_mem) ? tbp_mem : mk_id(sptr), carg.nargt, argt);
  ii = count = 0;

  for (itemp = list; itemp != ITEM_END; itemp = itemp->next) {
    sp = itemp->t.stkp;
    if (SST_IDG(sp) == S_KEYWORD) {
      /* form is <ident> = <expression> */
      error(79, 3, gbl.lineno, scn.id.name + SST_CVALG(itemp->t.stkp), CNULL);
      ARGT_ARG(argt, ii) = astb.i0;
      ii++;
      continue;
    }
    /* check arguments and add to ARGT list, handling derived type
     * arguments as special case
     */
    sptr1 = 0;
    if (SST_IDG(sp) == S_LVALUE)
      sptr1 = SST_LSYMG(sp);
    else if (SST_IDG(sp) == S_DERIVED || SST_IDG(sp) == S_IDENT)
      sptr1 = SST_SYMG(sp);
    else if (SST_IDG(sp) == S_SCONST) {
      (void)mkarg(sp, &dum);
      sptr1 = SST_SYMG(sp);
    }
    {

      /* get_byvalue parameter processing is handled in lowerilm.c for
         subroutine calls.
       */
      param_dummy = inc_dummy_param(sptr);

      if (pass_char_no_len(sptr, param_dummy)) {
        itemp->t.sptr = byvalue_ref_arg(sp, &dum, OP_REF, sptr);
        ARGT_ARG(argt, ii) = SST_ASTG(sp);

      } else {
        itemp->t.sptr = chkarg(sp, &dum);
        ARGT_ARG(argt, ii) = SST_ASTG(sp);
      }
      ii++;

      if (sptr1 && STYPEG(sptr1) == ST_PROC && DPDSCG(sptr1) &&
          SLNKG(sptr1) == 0) {
        SLNKP(sptr1, aux.list[ST_PROC]);
        aux.list[ST_PROC] = sptr1;
      }
    }
    /*
     * a negative value returned by mkarg is a negated alternate
     * return label
     */
    if (itemp->t.sptr <= 0)
      alt_ret++;
  }

exit_:
  SST_ASTP(stktop, ast);

  if (kwd_str)
    FREE(kwd_str);
}

void
subr_call(SST *stktop, ITEM *list)
{
  subr_call2(stktop, list, 0);
}

static void
fix_proc_pointer_call(SST *stktop, ITEM **list)
{
  /* Fix up pointer procedure call. If it's missing the pass object in the
   * arg list, add it. Also resolve the procedure pointer's iface if it has
   * not yet been resolved.
   */

  int func, pass_sym;
  int paramct, dpdsc, iface, ast, i;
  int arg, arg_sptr;
  int dtype, dtproc;
  SST *e1;
  ITEM *itemp, *itemp2;
  ast = SST_ASTG(stktop);
  switch (A_TYPEG(ast)) {
  case A_ID:
  case A_LABEL:
  case A_ENTRY:
  case A_SUBSCR:
  case A_SUBSTR:
  case A_MEM:
    func = memsym_of_ast(ast);
    pass_sym = pass_sym_of_ast(ast);
    proc_arginfo(func, &paramct, &dpdsc, &iface);
    break;
  default:
    return;
  }
  if (STYPEG(iface) != ST_PROC) {
    iface = findByNameStypeScope(SYMNAME(iface), ST_PROC, 0);
    if (iface) {
      proc_arginfo(iface, &paramct, &dpdsc, NULL);
      if (is_procedure_ptr(func)) {
        dtype = DTYPEG(func);
        dtproc = DTY(dtype + 1);
        DTY(dtproc + 3) = paramct;
        DTY(dtproc + 4) = dpdsc;
        DTY(dtproc + 2) = iface;
        DTY(dtproc + 1) = DTYPEG(iface);
      }
    } else
      return;
  }

  if (NOPASSG(func) || paramct <= 0)
    return;

  for (i = 0, itemp = *list; itemp != ITEM_END; itemp = itemp->next) {
    ++i;
  }

  if (*list != ITEM_END && (paramct - 1) <= i)
    return;

  if (!PASSG(func)) {
    /* check first arg */
    if (*list == ITEM_END) {
    insert_first_arg:
      e1 = (SST *)getitem(0, sizeof(SST));
      SST_IDP(e1, S_EXPR);
      SST_SYMP(e1, pass_sym);
      SST_ASTP(e1, check_member(ast, mk_id(pass_sym)));

      itemp = (ITEM *)getitem(0, sizeof(ITEM));
      itemp->t.stkp = e1;
      itemp->next = ITEM_END;
      *list = itemp;
    }
  } else {
    int pass_pos = find_dummy_position(iface, PASSG(func));
    if (pass_pos == 1 && *list == ITEM_END)
      goto insert_first_arg;
    if (pass_pos <= 1)
      return;
    for (i = 0, itemp = *list; itemp != ITEM_END; itemp = itemp->next) {
      e1 = itemp->t.stkp;
      if (i == pass_pos - 2) {
        e1 = (SST *)getitem(0, sizeof(SST));
        SST_IDP(e1, S_EXPR);
        SST_SYMP(e1, pass_sym);
        SST_ASTP(e1, check_member(ast, mk_id(pass_sym)));
        itemp2 = (ITEM *)getitem(0, sizeof(ITEM));
        itemp2->t.stkp = e1;
        itemp2->next = itemp->next;
        itemp->next = itemp2;
        break;
      }
      ++i;
    }
  }
}

void
ptrsubr_call(SST *stktop, ITEM *list)
{
  int sptr, sptr1, stype;
  int callee;
  ITEM *itemp;
  int count, alt_ret;
  int dum, i, ii;
  int dtproc, iface, paramct, dpdsc;
  int dtype;
  int ast;
  int argt;
  SST *sp;
  int param_dummy;
  char *kwd_str; /* where make_kwd_str saves the string */
  int pass_pos;

  fix_proc_pointer_call(stktop, &list);
  ast = 0; /* initialize just in case error occurs */
  kwd_str = NULL;
  pass_pos = -1;
  if (SST_IDG(stktop) != S_LVALUE) {
    sptr = SST_SYMG(stktop);
    callee = mk_id(sptr);
  } else {
    sptr = SST_LSYMG(stktop);
    if (!is_procedure_ptr(sptr))
      /* error must have occurred */
      goto exit_;
    callee = SST_ASTG(stktop);
  }
  if (FUNCG(sptr))
    /* sptr is a function */
    error(84, 3, gbl.lineno, SYMNAME(sptr), "- attempt to CALL a FUNCTION");
  dtype = DTYPEG(sptr);
#if DEBUG
  assert(DTY(dtype) == TY_PTR, "ptrsubr_call, expected TY_PTR dtype", sptr, 4);
#endif
  dtproc = DTY(dtype + 1);
#if DEBUG
  assert(DTY(dtproc) == TY_PROC, "ptrsubr_call, expected TY_PROC dtype", sptr,
         4);
#endif
  dtype = DTY(dtproc + 1);
  iface = DTY(dtproc + 2);
  paramct = DTY(dtproc + 3);
  dpdsc = DTY(dtproc + 4);
  if (iface != sptr && !paramct) {
    proc_arginfo(iface, &paramct, &dpdsc, NULL);
    DTY(dtproc + 3) = paramct;
    DTY(dtproc + 4) = dpdsc;
  }
  init_byval();
  if (dpdsc)
    kwd_str = make_keyword_str(paramct, dpdsc);

  if (flg.xref)
    xrefput(sptr, 'r');

  alt_ret = 0;
  count_actuals(list);
  count = carg.nent;

  /*
   * loop through the argument list to evaluate all of the arguments and
   * saving their values (ILM pointers);
   */
  if (kwd_str) {
    if (chk_arguments(sptr, count, list, kwd_str, paramct, dpdsc, callee,
                      &pass_pos))
      goto exit_;
    count_formal_args(paramct, dpdsc);
    count = carg.nent;
    argt = mk_argt(carg.nargt); /* mk_argt stuffs away count */
    ii = 0;
    for (i = 0; i < count; i++) {
      sp = ARG_STK(i);
      if (sp) {
        /* add to ARGT list, handling derived type arguments as
         * special case.
         */
        sptr1 = 0;
        if (SST_IDG(sp) == S_LVALUE)
          sptr1 = SST_LSYMG(sp);
        else if (SST_IDG(sp) == S_DERIVED || SST_IDG(sp) == S_IDENT)
          sptr1 = SST_SYMG(sp);
        else if (SST_IDG(sp) == S_SCONST) {
          (void)mkarg(sp, &dum);
          sptr1 = SST_SYMG(sp);
        }
        {
          param_dummy = inc_dummy_param(sptr);
          if (!is_iso_cloc(SST_ASTG(sp)) && (A_TYPEG(SST_ASTG(sp)) != A_FUNC) &&
              is_iso_cptr(A_DTYPEG(SST_ASTG(sp)))) {
            /* rewrite iso cptr references,
               do not rewrite functions returning iso_cptr,
               do not rewrite iso c_loc
             */

            ARGT_ARG(argt, ii) = rewrite_cptr_references(SST_ASTG(sp));
            ii++;
          } else if (pass_char_no_len(sptr, param_dummy)) {
            byvalue_ref_arg(sp, &dum, OP_REF, sptr);
            ARGT_ARG(argt, ii) = SST_ASTG(sp);
            ii++;
          } else {
            /* byval arguments done in lowerilm.c for  subroutines */
            ARGT_ARG(argt, ii) = ARG_AST(i);
            ii++;
          }
          if (sptr1 && STYPEG(sptr1) == ST_PROC && DPDSCG(sptr1) &&
              SLNKG(sptr1) == 0) {
            SLNKP(sptr1, aux.list[ST_PROC]);
            aux.list[ST_PROC] = sptr1;
          }
        }
      } else if (i == pass_pos) {
        ARGT_ARG(argt, ii) = A_PARENTG(callee);
        ii++;
      } else {
        int npad;
        for (npad = ARG_AST(i); npad > 0; npad--) {
          ARGT_ARG(argt, ii) = astb.ptr0;
          ii++;
        }
      }
    }
    ast = mk_func_node(A_CALL, callee, carg.nargt, argt);
    goto exit_;
  }
  argt = mk_argt(carg.nargt); /* mk_argt stuffs away count */
  ast = mk_func_node(A_CALL, callee, carg.nargt, argt);
  ii = count = 0;

  for (itemp = list; itemp != ITEM_END; itemp = itemp->next) {
    sp = itemp->t.stkp;
    if (SST_IDG(sp) == S_KEYWORD) {
      /* form is <ident> = <expression> */
      error(79, 3, gbl.lineno, scn.id.name + SST_CVALG(itemp->t.stkp), CNULL);
      ARGT_ARG(argt, ii) = astb.i0;
      ii++;
      continue;
    }
    /* check arguments and add to ARGT list, handling derived type
     * arguments as special case
     */
    sptr1 = 0;
    if (SST_IDG(sp) == S_LVALUE)
      sptr1 = SST_LSYMG(sp);
    else if (SST_IDG(sp) == S_DERIVED || SST_IDG(sp) == S_IDENT)
      sptr1 = SST_SYMG(sp);
    else if (SST_IDG(sp) == S_SCONST) {
      (void)mkarg(sp, &dum);
      sptr1 = SST_SYMG(sp);
    }
    {
      /* get_byvalue parameter processing is handled in lowerilm.c for
         subroutine calls.
       */
      param_dummy = inc_dummy_param(sptr);
      if (pass_char_no_len(sptr, param_dummy)) {
        itemp->t.sptr = byvalue_ref_arg(sp, &dum, OP_REF, sptr);
        ARGT_ARG(argt, ii) = SST_ASTG(sp);

      } else {
        itemp->t.sptr = chkarg(sp, &dum);
        ARGT_ARG(argt, ii) = SST_ASTG(sp);
      }
      ii++;
    }
    /*
     * a negative value returned by mkarg is a negated alternate
     * return label
     */
    if (itemp->t.sptr <= 0)
      alt_ret++;
  }

exit_:
  SST_ASTP(stktop, ast);

  if (kwd_str)
    FREE(kwd_str);
}

/*---------------------------------------------------------------------*/

/* the purpose of these ASTs is to transfer information to the
 * ACL constructors in semutil2.c.  They should be ignored by
 * by anything not involved in data initialization.
 */
static void
gen_init_intrin_call(SST *stkp, int pdsym, int argt_count, int dtype,
                     int elemental)
{
  int argt = mk_argt(argt_count); /* space for arguments */
  int func_ast;
  int ast;
  int i;
  int dtyper = dtype;
  SST *arg1;
  int arg1dtype;
  int dum;
  SST *s;

  for (i = 0; i < argt_count; i++) {
    s = (ARG_STK(i));
    if (!s) {
      ARGT_ARG(argt, i) = astb.i0;
    } else if (SST_IDG(s) == S_IDENT || SST_IDG(s) == S_ACONST) {
      SST_ASTP(s, 0);
      (void)mkarg(s, &dum);
      XFR_ARGAST(i);
      ARGT_ARG(argt, i) = ARG_AST(i);
    } else if (ARG_AST(i)) {
      ARGT_ARG(argt, i) = ARG_AST(i);
    }
  }
  func_ast = mk_id(pdsym);

  ast = mk_func_node(A_INTR, func_ast, argt_count, argt);
  A_DTYPEP(ast, dtype);

  if (elemental) {
    arg1 = ARG_STK(0);
    arg1dtype = SST_DTYPEG(arg1);
    if (DTY(arg1dtype) == TY_ARRAY) {
      dtyper = mk_array_type(arg1dtype, dtype);
      A_DTYPEP(ast, dtyper);
      A_SHAPEP(ast, SST_SHAPEG(arg1));
    }
  }
  SST_DTYPEP(stkp, dtyper);

  EXPSTP(pdsym, 1); /* freeze predeclared */
  SST_IDP(stkp, S_EXPR);
  SST_ASTP(stkp, ast);
  A_OPTYPEP(ast, INTASTG(pdsym));
}

/*
 * Generate a symbol for newer specifics of older generic intrinsics, i.e.,
 * those not
 * defined in syminidf.h
 */
static int
gen_newer_intrin(int sptrgenr, int dtype)
{
  char *intrin_nmptr = SYMNAME(sptrgenr);
  char nmptr[STANDARD_MAXIDLEN + 3] = ".";
  int sptr;

  if (strcmp(intrin_nmptr, "acos") == 0 || strcmp(intrin_nmptr, "asin") == 0 ||
      strcmp(intrin_nmptr, "atan") == 0 || strcmp(intrin_nmptr, "cosh") == 0 ||
      strcmp(intrin_nmptr, "sinh") == 0 || strcmp(intrin_nmptr, "tanh") == 0 ||
      strcmp(intrin_nmptr, "tan") == 0) {
    if (DT_ISCMPLX(dtype)) {
      switch (DTY(dtype)) {
      case TY_DCMPLX:
        strcat(nmptr, "cd");
        break;
      case TY_CMPLX:
        strcat(nmptr, "c");
        break;
      default:
        interr(
            "gen_newer_intrin: unknown type for inverse trigonmetric intrinsic",
            DTY(dtype), 2);
        return 0;
      }
      strcat(nmptr, intrin_nmptr);

      sptr = getsymbol(nmptr);
      STYPEP(sptr, ST_INTRIN);
      DTYPEP(sptr, 0);
      SYMLKP(sptr, sptrgenr);
      PNMPTRP(sptr, PNMPTRG(GREALG(sptrgenr)));
      PARAMCTP(sptr, 1);
      ILMP(sptr, ILMG(GREALG(sptrgenr)));
      ARRAYFP(sptr, ARRAYFG(GREALG(sptrgenr)));
      ARGTYPP(sptr, dtype);
      INTTYPP(sptr, dtype);
      INTASTP(sptr, NEW_INTRIN);

      switch (DTY(dtype)) {
      case TY_DCMPLX:
        GDCMPLXP(sptrgenr, sptr);
        break;
      case TY_CMPLX:
        GCMPLXP(sptrgenr, sptr);
        break;
      }
    }
    return sptr;
  }

  return 0;
}

static int
cmp_mod_scope(SPTR sptr)
{
  SPTR scope1, scope2;

  scope1 = stb.curr_scope;
  if (IS_PROC(STYPEG(scope1))) {
    scope1 = SCOPEG(scope1);
  }
  scope2 = SCOPEG(sptr);
  return scope1 == scope2;
}

/** \brief Handle Generic and Intrinsic function calls.
 */
int
ref_intrin(SST *stktop, ITEM *list)
{
  int sptr, fsptr, sptre, dtype, dtype1, argtyp, paramct;
  int f_dt, ddt;
  int opc, count, const_cnt;
  ITEM *ip1;
  SST *sp;
  LOGICAL frozen;
  ACL *expracl;
  int ast;
  int argt;
  int i;
  int intast;
  int shaper;
  int cp;
  int func_ast;
  int argdtype;
  int dtyper;
  int func_type;
  int dum;
  int dt_cast_word;
  int hpf_sym;
  int tmp, tmp_ast;
  char tmpnm[64];
  FtnRtlEnum rtlRtn;
  int intrin; /* one of the I_* constants */
  int is_real2_arg_error = 0;

  dtyper = 0;
  dtype1 = 0;
  sptr = 0; /* for min and max character */
  SST_CVLENP(stktop, 0);
  sptre = SST_SYMG(stktop);
  if (STYPEG(sptre) == ST_INTRIN) {
    SPTR sptr2 = findByNameStypeScope(SYMNAME(sptre), ST_ALIAS, 0);
    if (sptr2 > NOSYM && SYMLKG(sptr2) == sptre && PRIVATEG(sptr2) &&
        (!IN_MODULE || cmp_mod_scope(sptr2))) {
      error(1015, 3, gbl.lineno, SYMNAME(sptr2), NULL);
    }
  }

  if (sptre >= stb.firstusym)
    return generic_func(sptre, stktop, list);

  frozen = EXPSTG(sptre);
  if (list == ITEM_END)
    goto intrinsic_error;
  /*
   * Count number of arguments without type changing arguments in case
   * we need to recover by assuming reference is to an external function.
   */
  count = 0;
  for (ip1 = list; ip1 != ITEM_END; ip1 = ip1->next) {
    count++;
    switch (SST_IDG(ip1->t.stkp)) {
    case S_TRIPLE:
      goto intrinsic_error;
    default:
      break;
    }
  }
  /* position the arguments per the keyword argument string. note
   * that the number of arguments processed by get_kwd_args is
   *     max(actual arg count, number of 'non-variable' arguments).
   */
  i = KWDCNTG(sptre);
  if (count > i)
    i = count;
  if (get_kwd_args(list, i, KWDARGSTR(sptre)))
    goto intrinsic_error;

  intrin = INTASTG(sptre);
  dt_cast_word = 0;
  if (STYPEG(sptre) == ST_GENERIC) {
    /*
     * f2003 says that a boz literal can appear as an argument to
     * the real, dble, cmplx, and dcmplx intrinsics and its value
     * is used as the respective internal respresentation
     */
    switch (intrin) {
    case I_DBLE:
    case I_DCMPLX:
      dt_cast_word = DT_DBLE;
      break;
    case I_IAND:
      sem.mpaccatomic.rmw_op = AOP_AND;
      break;
    case I_IOR:
      sem.mpaccatomic.rmw_op = AOP_OR;
      break;
    case I_IEOR:
      sem.mpaccatomic.rmw_op = AOP_XOR;
      break;
    case I_MIN:
      sem.mpaccatomic.rmw_op = AOP_MIN;
      break;
    case I_MAX:
      sem.mpaccatomic.rmw_op = AOP_MAX;
      break;
    }
  }
  sp = ARG_STK(0); /* Save 1st arg's semantic stack pointer */
  dtype1 = 0;
  for (i = 0; i < count; i++) {
    sp = ARG_STK(i);
    argdtype = SST_DTYPEG(sp);
    if (argdtype == DT_WORD || argdtype == DT_DWORD) {
      if (dt_cast_word) {
        cngtyp(sp, dt_cast_word);
        argdtype = SST_DTYPEG(sp);
      } else if (argdtype == DT_WORD) {
      }
    }
    if (!dtype1) {
      f_dt = dtype1 = argdtype; /* Save 1st arg's data type */
      if (DTY(argdtype) == TY_ARRAY)
        break;
    } else {
      /* check rest of args to see if they might be array. */
      /* assert.  haven't seen an array argument yet. */
      if (DTY(argdtype) == TY_ARRAY) {
        f_dt = dtype1 = argdtype; /* Save data type */
        break;
      }
    }
  }

  if (STYPEG(sptre) == ST_GENERIC) {
    if (SST_ISNONDECC(sp)) {
      cngtyp(sp, DT_INT);
    }
    dtype = DDTG(dtype1);
    /* apply the KIND argument if applicable */
    /* determine specific intrinsic name from data type of first argument */
    switch (DTY(dtype)) {
    case TY_BLOG:
    case TY_BINT:
      sptr = GINTG(sptre);
      if (ARGTYPG(sptr) == INTTYPG(sptr))
        dtyper = dtype;
      break;
    case TY_SLOG:
    case TY_SINT:
      if ((sptr = GSINTG(sptre)))
        break;
    case TY_WORD:
    case TY_LOG:
    case TY_INT:
      sptr = GINTG(sptre);
      break;
    case TY_DWORD:
    case TY_LOG8:
    case TY_INT8:
      sptr = GINT8G(sptre);
      break;
    case TY_REAL:
      sptr = GREALG(sptre);
      break;
    case TY_DBLE:
      sptr = GDBLEG(sptre);
      break;
    case TY_QUAD:
      sptr = GQUADG(sptre);
      break;
    case TY_CMPLX:
      sptr = GCMPLXG(sptre);
      break;
    case TY_DCMPLX:
      sptr = GDCMPLXG(sptre);
      break;
    case TY_QCMPLX:
      sptr = GQCMPLXG(sptre);
      break;
    case TY_CHAR:
    case TY_NCHAR:
      if ((intrin == I_MAX || intrin == I_MIN) && sem.dinit_data) {
        paramct = 12;
        argtyp = dtype1;
        /* Should really check type of next argument is char also */
        rtlRtn = intrin == I_MAX ? RTE_max : RTE_min;
        sptr = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtyper);
        gen_init_intrin_call(stktop, sptr, count, DDTG(dtype1), TRUE);
        A_OPTYPEP(SST_ASTG(stktop), intrin);
        return 1;
      }
    default:
      sptr = 0;
      break;
    }

    if (sptr == 0) {
      sptr = gen_newer_intrin(SST_SYMG(stktop), dtype);
    }

    if (sptr <= 0)
      goto intrinsic_error;
    assert(STYPEG(sptr) == ST_INTRIN, "ref_intrin: bad intrinsic sptr", sptr,
           3);
    /*
     * determine if resolved specific has the same name as the generic;
     * If it is, must 'freeze' the specific.
     */
    if (strcmp(SYMNAME(sptr), SYMNAME(sptre)) == 0)
      EXPSTP(sptr, 1);
  } else {
    /*  SPECIFICs  */
    static int float_intr_warn = 0;
    if (XBIT(124, 0x10)) {
      /* -i8 */
      /* the intrinsic ast opcodes of the following integer*8
       * intrinsics, must appear as special cases in
       * semfunc2.c:intrinsic_as_arg() so that the correct
       * function name is selected given the integer name.
       */
      switch (intrin) {
      case I_IABS:
        sptre = intast_sym[I_KIABS];
        break;
      case I_IDIM:
        sptre = intast_sym[I_KIDIM];
        break;
      case I_IDNINT:
        sptre = intast_sym[I_KIDNNT];
        break;
      case I_ISIGN:
        sptre = intast_sym[I_KISIGN];
        break;
      case I_MAX0:
        sptre = intast_sym[I_KMAX0];
        break;
      case I_MIN0:
        sptre = intast_sym[I_KMIN0];
        break;
      case I_MAX1:
        sptre = intast_sym[I_KMAX1];
        break;
      case I_MIN1:
        sptre = intast_sym[I_KMIN1];
        break;
      }
    }
    if (XBIT(124, 0x8)) {
      /* -r8 */
      /* the intrinsic ast opcodes of the following double real/complex
       * intrinsics, must appear as special cases in
       * semfunc2.c:intrinsic_as_arg() so that the correct
       * function name is selected given the real/complex name.
       */
      switch (intrin) {
      case I_ALOG:
        sptre = intast_sym[I_DLOG];
        break;
      case I_ALOG10:
        sptre = intast_sym[I_DLOG10];
        break;
      case I_AMAX1:
        sptre = intast_sym[I_DMAX1];
        break;
      case I_AMIN1:
        sptre = intast_sym[I_DMIN1];
        break;
      case I_AMOD:
        sptre = intast_sym[I_DMOD];
        break;
      case I_CABS:
        sptre = intast_sym[I_CDABS];
        break;
      case I_CSQRT:
        sptre = intast_sym[I_CDSQRT];
        break;
      case I_CLOG:
        sptre = intast_sym[I_CDLOG];
        break;
      case I_CEXP:
        sptre = intast_sym[I_CDEXP];
        break;
      case I_CSIN:
        sptre = intast_sym[I_CDSIN];
        break;
      case I_CCOS:
        sptre = intast_sym[I_CDCOS];
        break;
      case I_FLOATI:
        if (XBIT(124, 0x80000)) {
          sptre = intast_sym[I_DFLOTI];
          if (!float_intr_warn) {
            float_intr_warn = 1;
            error(155, 2, gbl.lineno,
                  "The type of FLOAT is now double precision with -r8", CNULL);
          }
        }
        break;
      case I_FLOATJ:
        if (XBIT(124, 0x80000)) {
          sptre = intast_sym[I_DFLOTJ];
          if (!float_intr_warn) {
            float_intr_warn = 1;
            error(155, 2, gbl.lineno,
                  "The type of FLOAT is now double precision with -r8", CNULL);
          }
        }
        break;
      case I_FLOAT:
        if (XBIT(124, 0x80000)) {
          sptre = intast_sym[I_DFLOAT];
          if (!float_intr_warn) {
            float_intr_warn = 1;
            error(155, 2, gbl.lineno,
                  "The type of FLOAT is now double precision with -r8", CNULL);
          }
        }
        break;
      }
    }
    sptr = sptre;
  }

  intast = INTASTG(sptr);

  /*
   * Assertion: sptr now points to the specific intrinsic entry ST_INTRIN
   * that was either specified with a generic name or a specific name.
   * sptre EITHER points to the generic name symbol entry or the specific
   * name symbol entry (if generic and specific have same names).
   */
  dtype = INTTYPG(sptr);

  /*
   * Determine intrinsic's ILM and number and type of arguments.
   */
  if (DTY(SST_DTYPEG(sp)) == TY_ARRAY) {
    opc = ARRAYFG(sptr); /* Get ilm for Vectors */
    /* Check if vectors disallowed and not a type conversion intrinsic.
     * Vectors okay for type conversion intrinsics.
     */
    if (ILMG(sptr) == IM_LOC)
      opc = IM_LOC;
    else if (opc == 0 && ILMG(sptr) != 0)
      goto intrinsic_error;
    /* opc == 0 */
  } else
    opc = ILMG(sptr);
  argtyp = ARGTYPG(sptr);
  paramct = PARAMCTG(sptr);

  if (paramct != 12 && paramct != 11 && count > paramct) {
    goto intrinsic_error;
  }

  if (paramct == 11) { /* CMPLX/DCMPLX intrinsic */
    if (ARG_STK(1))
      /* Two arguments in reference, cause conversion of each part to
       * real/dble
       */

      dtype = dtype == DT_CMPLX ? stb.user.dt_real : DT_DBLE;

    else /* treat like typical type conversion intrinsic */
      paramct = 1;
  } else {
    switch (intast) {
    case I_FLOAT:
    case I_DFLOAT:
      ddt = DDTG(f_dt);
      if (ddt == DT_INT8)
        argtyp = DT_INT8;
      break;
    }
  }

  if (sem.dinit_data) {
    switch (ILMG(sptr)) {
    case IM_ICHAR:
      gen_init_intrin_call(stktop, sptr, count, stb.user.dt_int, TRUE);
      return 1;
    case IM_IISHFT:
    case IM_JISHFT:
    case IM_KISHFT:
      gen_init_intrin_call(stktop, sptr, count, stb.user.dt_int, TRUE);
      return 1;
    case IM_IMAX:
    case IM_I8MAX:
    case IM_RMAX:
    case IM_DMAX:
    case IM_IMIN:
    case IM_I8MIN:
    case IM_RMIN:
    case IM_DMIN:
      gen_init_intrin_call(stktop, sptr, count, DDTG(dtype1), TRUE);
      return 1;
    case 0:
      switch (intrin) {
      case I_DBLE:
      case I_DFLOAT:
      case I_FLOAT:
      case I_REAL:
        gen_init_intrin_call(stktop, sptre, count, DDTG(dtype1), TRUE);
        return 1;
      }
    }
  }

  /*
   * Count number of constant arguments.
   */
  const_cnt = 0;
  for (i = 0; i < count; i++)
    if (ARG_STK(i) && is_sst_const(ARG_STK(i)))
      const_cnt++;

  /*  If all arguments are constants, attempt to constant fold  */

  if (const_cnt == count) {

    INT conval, con1, con2, res[4], num1[4], num2[4];
    int q0;
    int qhalf;
    char ch;

    switch (opc) {
    case IM_LOC:
#ifdef I_C_ASSOCIATED
    case IM_C_ASSOC:
#endif
      goto no_const_fold;
    }

    argt = mk_argt(count); /* space for arguments */
    for (i = 0; i < count; i++) {
      sp = ARG_STK(i);
      if (opc == 0) {
        /* type conversion: for the two argument CMPLX/DCMPLX, each
         * part is converted to the real type implied by the intrinsic;
         * otherwise, the operands are converted to the result type
         * of the intrinsic.
         */
        if (XBIT(124, 0x8)) {
          /* -r8 */
          if (intast == I_SNGL) {
            dtype = DT_REAL8;
          }
        }
        cngtyp(sp, dtype);
      } else if (DTY(argtyp) == TY_CHAR && DTY(SST_DTYPEG(sp)) == TY_CHAR) {
        if (opc == IM_ICHAR && i == 0)
          dtyper = stb.user.dt_int;
      } else if ((DTY(argtyp) == TY_NCHAR || DTY(argtyp) == TY_CHAR) &&
                 DTY(SST_DTYPEG(sp)) == TY_NCHAR) {
        /*
         * if the argument is character and the expected argument is
         * character, we don't call cngtyp since we represent argtyp
         * as a character of length 1
         */
        if (opc == IM_ICHAR && i == 0)
          dtyper = stb.user.dt_int;
      } else if (i == 2 && opc == IM_NINDEX)
        cngtyp(sp, DT_LOG);
      else if (opc == IM_ICHAR) {
        if (i == 0) {
          chktyp(sp, argtyp, TRUE);
          dtyper = stb.user.dt_int;
        } else {
          dtyper = set_kind_result(sp, DT_INT, TY_INT);
          if (!dtyper) {
            goto intrinsic_error;
          }
        }
      } else
        cngtyp(sp, argtyp);
      ARGT_ARG(argt, i) = SST_ASTG(sp);
    }

    con1 = GET_CVAL_ARG(0);
    if (paramct < 12) {
      if (paramct == 11) {
        /* CMPLX/DCMPLX with 2 args: cause both to make complex # */
        num1[0] = con1;
        num1[1] = GET_CVAL_ARG(1);

        if (DTY(dtype) == TY_REAL)
          conval = getcon(num1, DT_CMPLX);
        else
          conval = getcon(num1, DT_DCMPLX);

        goto const_return;
      }
      if (opc == 0) { /* type conversion intrinsic */
        conval = GET_CVAL_ARG(0);
        if (XBIT(124, 0x8)) {
          /* -r8 */
          if (intast == I_SNGL) {
            dtype = DT_REAL8;
            goto const_return_2;
          }
        }
        goto const_return;
      }
      switch (opc) {
      case IM_IABS:
        conval = con1 >= 0 ? con1 : -con1;
        goto const_return;
      case IM_ABS:
        xfabsv(con1, &res[0]);
        conval = res[0];
        goto const_return;
      case IM_DABS:
        GET_DBLE(num1, con1);
        xdabsv(num1, res);
        goto const_getcon;
      case IM_NINT:
        num1[0] = CONVAL2G(stb.flt0);
        if (xfcmp(con1, num1[0]) >= 0) {
          INT fv2_23 = 0x4b000000;
          if (xfcmp(con1, fv2_23) >= 0)
            xfadd(con1, CONVAL2G(stb.flt0), &res[0]);
          else
            xfadd(con1, CONVAL2G(stb.flthalf), &res[0]);
        } else {
          INT fvm2_23 = 0xcb000000;
          if (xfcmp(con1, fvm2_23) <= 0)
            xfsub(con1, CONVAL2G(stb.flt0), &res[0]);
          else
            xfsub(con1, CONVAL2G(stb.flthalf), &res[0]);
        }
        conval = cngcon(res[0], DT_REAL4, stb.user.dt_int);
        goto const_return;
      case IM_IDNINT:
        if (const_fold(OP_CMP, con1, stb.dbl0, DT_REAL8) >= 0) {
          INT dv2_52[2] = {0x43300000, 0x00000000};
          INT d2_52;
          d2_52 = getcon(dv2_52, DT_DBLE);
          if (const_fold(OP_CMP, con1, d2_52, DT_REAL8) >= 0)
            res[0] = const_fold(OP_ADD, con1, stb.dbl0, DT_REAL8);
          else
            res[0] = const_fold(OP_ADD, con1, stb.dblhalf, DT_REAL8);
        } else {
          INT dvm2_52[2] = {0xc3300000, 0x00000000};
          INT dm2_52;
          dm2_52 = getcon(dvm2_52, DT_DBLE);
          if (const_fold(OP_CMP, con1, dm2_52, DT_REAL8) <= 0)
            res[0] = const_fold(OP_SUB, con1, stb.dblhalf, DT_REAL8);
          else
            res[0] = const_fold(OP_SUB, con1, stb.dbl0, DT_REAL8);
        }
        conval = cngcon(res[0], DT_REAL8, stb.user.dt_int);
        goto const_return;
      case IM_IMAG:
      case IM_DIMAG:
        conval = CONVAL2G(con1);
        goto const_return;
      case IM_CONJG:
        res[0] = CONVAL1G(con1);
        con2 = CONVAL2G(con1);
        xfsub(CONVAL2G(stb.flt0), con2, &res[1]);
        goto const_getcon;
      case IM_DCONJG:
        res[0] = CONVAL1G(con1);
        con2 = CONVAL2G(con1);
        res[1] = const_fold(OP_SUB, (INT)stb.dbl0, con2, DT_REAL8);
        goto const_getcon;
#ifdef IM_DPROD
      case IM_DPROD:
        con2 = GET_CVAL_ARG(1);
        xdble(con1, num1);
        xdble(con2, num2);
        xdmul(num1, num2, res);
        goto const_getcon;
#endif
      case IM_AND8:
        con2 = GET_CVAL_ARG(1);
        GET_DBLE(num1, con1);
        GET_DBLE(num2, con2);
        and64(num1, num2, res);
        goto const_getcon;
      case IM_AND:
        con2 = GET_CVAL_ARG(1);
        conval = con1 & con2;
        goto const_return;
      case IM_OR8:
        con2 = GET_CVAL_ARG(1);
        GET_DBLE(num1, con1);
        GET_DBLE(num2, con2);
        or64(num1, num2, res);
        goto const_getcon;
      case IM_OR:
        con2 = GET_CVAL_ARG(1);
        conval = con1 | con2;
        goto const_return;
      case IM_XOR8:
        con2 = GET_CVAL_ARG(1);
        GET_DBLE(num1, con1);
        GET_DBLE(num2, con2);
        xor64(num1, num2, res);
        goto const_getcon;
      case IM_XOR:
        con2 = GET_CVAL_ARG(1);
        conval = con1 ^ con2;
        goto const_return;
      case IM_NOT8:
        GET_DBLE(num1, con1);
        not64(num1, res);
        goto const_getcon;
      case IM_NOT:
        conval = ~con1;
        goto const_return;
      case IM_I8MOD:
        /* i % j = i - (i / j)*j */
        con2 = GET_CVAL_ARG(1);
        GET_DBLE(num1, con1);
        GET_DBLE(num2, con2);
        div64(num1, num2, res);
        mul64(num2, res, res);
        sub64(num1, res, res);
        goto const_getcon;
      case IM_MOD:
        con2 = GET_CVAL_ARG(1);
        conval = con1 % con2;
        goto const_return;
      case IM_IDIM:
        con2 = GET_CVAL_ARG(1);
        conval = con1 > con2 ? con1 - con2 : 0;
        goto const_return;
      case IM_I8DIM:
        con2 = GET_CVAL_ARG(1);
        GET_DBLE(num1, con1);
        GET_DBLE(num2, con2);
        if (cmp64(num1, num2) > 0)
          sub64(num1, num2, res);
        else
          res[0] = res[1] = 0;
        goto const_getcon;
      case IM_DIM:
        con2 = GET_CVAL_ARG(1);
        if (xfcmp(con1, con2) > 0) {
          xfsub(con1, con2, &res[0]);
          conval = res[0];
        } else
          conval = CONVAL2G(stb.flt0);
        goto const_return;
      case IM_DDIM:
        con2 = GET_CVAL_ARG(1);
        if (const_fold(OP_CMP, con1, con2, DT_REAL8) > 0)
          conval = const_fold(OP_SUB, con1, con2, DT_REAL8);
        else
          conval = stb.dbl0;
        goto const_return;
      case IM_IISHFT:
        con2 = GET_CVAL_ARG(1);
        /*
         * because this ilm is used for the ISHFT intrinsic, count
         * is defined for values -16 to 16.
         */
        if (con2 >= 0) {
          if (con2 >= 16)
            conval = 0;
          else {
            conval = ULSHIFT(con1, con2);
            conval = ULSHIFT(conval, 16);
            conval = ARSHIFT(conval, 16);
          }
        } else {
          if (con2 <= -16)
            conval = 0;
          else {
            con1 &= 0xffff;
            conval = URSHIFT(con1, -con2);
          }
        }
        goto const_return;
      case IM_JISHFT:
        con2 = GET_CVAL_ARG(1);
        /*
         * because this ilm is used for the ISHFT intrinsic, count
         * is defined for values -32 to 32; some hw (i.e., n10) shifts
         * by cnt mod 32.
         */
        if (con2 >= 0) {
          if (con2 >= 32)
            conval = 0;
          else
            conval = ULSHIFT(con1, con2);
        } else {
          if (con2 <= -32)
            conval = 0;
          else
            conval = URSHIFT(con1, -con2);
        }
        goto const_return;
      case IM_KISHFT:
        con2 = GET_CVAL_ARG(1);
        /* con1 and con2 are symbol pointers */
        /* get the value for con2 */
        con2 = CONVAL2G(con2);
        res[0] = CONVAL1G(con1);
        res[1] = CONVAL2G(con1);
        if (con2 >= 0) {
          if (con2 >= 64) {
            res[0] = 0;
            res[1] = 0;
          } else if (con2 >= 32) {
            /* shift con1 by 32 bits or more */
            res[0] = ULSHIFT(res[1], con2 - 32);
            res[1] = 0;
          } else {
            /* shift by less than 32 bits; shift high-order
             * bits of low-order word into high-order word */
            res[0] = ULSHIFT(res[0], con2) | URSHIFT(res[1], 32 - con2);
            res[1] = ULSHIFT(res[1], con2);
          }
        } else {
          con2 = -con2;
          if (con2 >= 64) {
            res[0] = 0;
            res[1] = 0;
          } else if (con2 >= 32) {
            /* shift con1 by 32 bits or more */
            res[1] = URSHIFT(res[0], con2 - 32);
            res[0] = 0;
          } else {
            /* shift by less than 32 bits; shift low-order
             * bits of high-order word into low-order word */
            res[1] = URSHIFT(res[1], con2) | ULSHIFT(res[0], 32 - con2);
            res[0] = URSHIFT(res[0], con2);
          }
        }
        conval = getcon(res, DT_INT8);
        goto const_return;
      case IM_ICHAR:
        if (DTY(SST_DTYPEG(ARG_STK(0))) == TY_NCHAR) { /* kanji */
          int dum, clen;
          assert(DTY(DTYPEG(con1)) == TY_CHAR || DTY(DTYPEG(con1)) == TY_NCHAR,
                 "ref_intrin:KK", con1, 3);
          con2 = CONVAL1G(con1);
          clen = string_length(DTYPEG(con2));
          conval = kanji_char((unsigned char *)stb.n_base + CONVAL1G(con2),
                              clen, &dum);
        } else
          conval = stb.n_base[CONVAL1G(con1)] & 0xff;

        if (!dtyper)
          dtyper = stb.user.dt_int;
        dtype = dtyper;
        if (DTY(dtyper) == TY_INT8) {
          /* The user default integer is integer*8, but INTTYP(ICHAR)
           * may still be DT_INT4 because of -i8.  Force the type to
           * DT_INT8 -- a better way to do this may be to store
           * DT_INT8 in the INTTYP field in sym_init() if -i8
           * (-x 124 0x10) was present.
           */
          res[0] = 0;
          res[1] = conval;
          conval = getcon(res, DT_INT8);
          dtype = DT_INT8;
        }
        goto const_return_2;
      case IM_CHAR:
        ch = con1;
        conval = getstring(&ch, 1);
        goto const_return;

      case IM_GE:
      case IM_GT:
      case IM_LE:
      case IM_LT:
        dtype = SST_DTYPEG(ARG_STK(0));
        /* two arguments must both be either TY_CHAR or TY_NCHAR: */
        if (DTY(dtype) != DTY(SST_DTYPEG(ARG_STK(1))))
          goto intrinsic_error;
        con2 = GET_CVAL_ARG(1);
        conval = const_fold(OP_CMP, con1, con2, dtype);

        switch (opc) {
        case IM_GE:
          conval = conval >= 0 ? SCFTN_TRUE : SCFTN_FALSE;
          break;
        case IM_GT:
          conval = conval > 0 ? SCFTN_TRUE : SCFTN_FALSE;
          break;
        case IM_LE:
          conval = conval <= 0 ? SCFTN_TRUE : SCFTN_FALSE;
          break;
        case IM_LT:
          conval = conval < 0 ? SCFTN_TRUE : SCFTN_FALSE;
        }

        /* Convert constant result logical type if -i8 turned on */

        if (DTY(stb.user.dt_log) == TY_LOG8) {
          dtype = DT_LOG8;
          conval = cngcon(conval, DT_LOG4, dtype);
          goto const_return_2;
        }
        goto const_return;
      case IM_IIBSET:
      case IM_JIBSET:
        /* how many bits to use from the first argument */
        i = size_of(dtype);
        i = i * 8;
        con2 = GET_CVAL_ARG(1);
        /* take only lower bits of con2, that is, modulo i */
        con2 = con2 % i;
        /* set bit 'con2' in 'con1' */
        conval = con1 | (1 << con2);
        goto const_return;
      case IM_KIBSET:
        /* how many bits to use from the first argument */
        i = size_of(dtype);
        i = i * 8;
        GET_DBLE(num1, con1);
        con2 = GET_CVAL_ARG(1);
        GET_DBLE(num2, con2);
        con2 = num2[1];
        /* take only lower bits of con2, that is, modulo i */
        con2 = con2 % i;
        res[2] = res[3] = 0;
        res[0] = num1[0];
        res[1] = num1[1];
        if (con2 >= 32) {
          res[0] |= 1 << (con2 - 32);
        } else {
          res[1] |= 1 << con2;
        }
        goto const_getcon;

      default:
        switch (intast) {
        case I_IISIGN:
        case I_JISIGN:
        case I_ISIGN:
          conval = con1;
          if (conval < 0 && conval != 0x80000000)
            conval = -conval;
          con2 = GET_CVAL_ARG(1);
          if (con2 < 0 && conval != 0x80000000)
            conval = -conval;
          goto const_return;
        case I_KISIGN:
          GET_DBLE(res, con1);
          GET_DBLE(num1, stb.k0);
          if (cmp64(res, num1) < 0)
            neg64(res, res);
          con2 = GET_CVAL_ARG(1);
          GET_DBLE(num2, con2);
          if (cmp64(num2, num1) < 0)
            neg64(res, res);
          goto const_getcon;
        case I_SIGN:
          xfabsv(con1, &conval);
          con2 = GET_CVAL_ARG(1);
          num1[0] = CONVAL2G(stb.flt0);
          if (con2 == CONVAL2G(stb.fltm0) || xfcmp(con2, num1[0]) < 0) {
            /* IEEE -0.0 , or < 0.0 */
            xfneg(conval, &conval);
          }
          goto const_return;
        case I_DSIGN:
          GET_DBLE(res, con1);
          xdabsv(res, res);
          con2 = GET_CVAL_ARG(1);
          GET_DBLE(num2, con2);
          GET_DBLE(num1, stb.dbl0);
          if (con2 == stb.dblm0 || xdcmp(num2, num1) < 0) {
            /* IEEE -0.0 , or < 0.0 */
            xdneg(res, res);
          }
          goto const_getcon;
        default:
          break;
        }
        break;
      }
    } else { /* max or min intrinsic */
      switch (opc) {
      case IM_IMAX:
        conval = con1;
        for (i = 1; i < count; i++) {
          con1 = GET_CVAL_ARG(i);
          if (con1 > conval)
            conval = con1;
        }
        break;
      case IM_I8MAX:
        conval = con1;
        for (i = 1; i < count; i++) {
          con1 = GET_CVAL_ARG(i);
          if (const_fold(OP_CMP, con1, conval, DT_INT8) > 0)
            conval = con1;
        }
        break;
      case IM_RMAX:
        conval = con1;
        for (i = 1; i < count; i++) {
          con1 = GET_CVAL_ARG(i);
          if (xfcmp(con1, conval) > 0)
            conval = con1;
        }
        break;
      case IM_DMAX:
        conval = con1;
        for (i = 1; i < count; i++) {
          con1 = GET_CVAL_ARG(i);
          if (const_fold(OP_CMP, con1, conval, DT_REAL8) > 0)
            conval = con1;
        }
        break;
      case IM_IMIN:
        conval = con1;
        for (i = 1; i < count; i++) {
          con1 = GET_CVAL_ARG(i);
          if (con1 < conval)
            conval = con1;
        }
        break;
      case IM_I8MIN:
        conval = con1;
        for (i = 1; i < count; i++) {
          con1 = GET_CVAL_ARG(i);
          if (const_fold(OP_CMP, con1, conval, DT_INT8) < 0)
            conval = con1;
        }
        break;
      case IM_RMIN:
        conval = con1;
        for (i = 1; i < count; i++) {
          con1 = GET_CVAL_ARG(i);
          if (xfcmp(con1, conval) < 0)
            conval = con1;
        }
        break;
      case IM_DMIN:
        conval = con1;
        for (i = 1; i < count; i++) {
          con1 = GET_CVAL_ARG(i);
          if (const_fold(OP_CMP, con1, conval, DT_REAL8) < 0)
            conval = con1;
        }
        break;
      default:
        goto no_const_fold;
      }
      if (argtyp != dtype)
        conval = cngcon(conval, argtyp, dtype);
      goto const_return;
    }
    goto no_const_fold;

  const_getcon:
    conval = getcon(res, dtype);
  const_return:
    if (ARGTYPG(sptr) == INTTYPG(sptr) && dtyper) {
      dtype = dtyper;
    } else {
      dtype = INTTYPG(sptr);
    }
  const_return_2:
    SST_IDP(stktop, S_CONST);
    SST_DTYPEP(stktop, dtype);
    SST_CVALP(stktop, conval);
    EXPSTP(sptre, 1); /* freeze generic or specific name */
    SST_SHAPEP(stktop, 0);

    ast = mk_cval1(conval, dtype);
    SST_ASTP(stktop, ast);

    return conval;
  }

no_const_fold:
  /*
   * Validate arguments specified.
   */
  shaper = 0;
  if (opc == 0 && paramct == 11)
    /* CMPLX/DCMPLX intrinsic */
    for (i = 0; i < count; XFR_ARGAST(i), i++) {
      sp = ARG_STK(i);
      chktyp(sp, DT_NUMERIC, FALSE);
      if (!shaper)
        shaper = SST_SHAPEG(sp);
    }
  else
    for (i = 0; i < count; XFR_ARGAST(i), i++) {
      sp = ARG_STK(i);
      if (opc == IM_LOC) {
        if (sc_local_passbyvalue(SST_SYMG(sp), GBL_CURRFUNC)) {
          error(155, 3, gbl.lineno,
                "unsupported LOC of VALUE parameter:", SYMNAME(SST_SYMG(sp)));
        } else if (mklvalue(sp, 3) == 0)
          goto intrinsic_error;
      }
      else if (DTYG(SST_DTYPEG(sp)) == TY_NCHAR) {
        switch (opc) {
        case IM_ICHAR:
          dtyper = stb.user.dt_int;
        case IM_NCHAR:
        case IM_NINDEX:
        case IM_NLEN:
        case IM_GE:
        case IM_GT:
        case IM_LE:
        case IM_LT:
          break;
        default:
          chktyp(sp, argtyp, TRUE);
          continue;
        }
        mkexpr(sp);
      }
      else {
        switch (opc) {
        case IM_GE:
        case IM_GT:
        case IM_LE:
        case IM_LT:
          if (DTYG(SST_DTYPEG(sp)) != TY_CHAR)
            goto intrinsic_error;
          mkexpr(sp);
          break;
        case IM_ICHAR:
          if (i == 0) {
            chktyp(sp, argtyp, TRUE);
            dtyper = stb.user.dt_int;
          } else {
            dtyper = set_kind_result(sp, DT_INT, TY_INT);
            if (!dtyper) {
              goto intrinsic_error;
            }
          }
          break;
#ifdef I_C_ASSOCIATED
        case IM_C_ASSOC:
          if (SST_IDG(sp) == S_EXPR)
            (void)tempify(sp);
          mkarg(sp, &dum);
          break;
#endif
        default:
          if (i == 2 && opc == IM_NINDEX)
            cngtyp(sp, DT_LOG);
          else
            chktyp(sp, argtyp, TRUE);
          break;
        }
      }

      if (!shaper)
        shaper = SST_SHAPEG(sp);
    }

  if (paramct < 12) {
    if (paramct == 11) {
      /* complex intrinsic with 2 args: cause both to make complex # */
      /* just mark as a type conversion, vectors ok - ILMG & ARRAYF
       * fields of type conversions intrinsics are 0.
       */
      opc = 0;
    }
  } else { /* max or min intrinsic */
    if (dtype != argtyp) {
      SST_IDP(stktop, S_EXPR);
      SST_DTYPEP(stktop, argtyp);
      cngtyp(stktop, dtype);
    }
  }

  /* SUCCESSFUL GENERIC/INTRINSIC PROCESSING */
  /* The data type of the result comes from the specific intrinsic used.
   * The shape of the result comes from the shape of the 1st argument.
   */
  if (opc == IM_LOC) {
    shaper = 0;
    dtyper = DT_PTR;
    switch (intast) {
    case I_C_LOC:
      ddt = get_iso_ptrtype("c_ptr");
      if (ddt)
        dtyper = ddt;
      break;
    case I_C_FUNLOC:
      ddt = get_iso_ptrtype("c_funptr");
      if (ddt)
        dtyper = ddt;
      break;
    }
  } else {
    if (!dtyper) {
      switch (intast) {
      case I_BITEST:
      case I_BJTEST:
      case I_BKTEST:
      case I_BTEST:
        dtyper = stb.user.dt_log;
        break;
      default:
        dtyper = INTTYPG(sptr);
        break;
      }
    }
    if (DTY(dtype1) == TY_ARRAY && (ARRAYFG(sptr) || !opc)) {
      /* Assertion:  First argument is an array AND intrinsic can
       *             handle vectors (this includes the type conversion
       *             intrinsics).  Create an array data type.
       */
      dtype = dup_array_dtype(dtype1);
      DTY(dtype + 1) = dtyper;
      dtyper = dtype;
    } else {
      if (shaper)
        interr("ref_intrin: result has shape, but dtype is not array", dtyper,
               2);
    }
  }

  SST_DTYPEP(stktop, dtyper);
  SST_IDP(stktop, S_EXPR);

  /* It is time to freeze the symbol's use as an intrinsic reference.
   * Use sptre which points to the generic or specific name that was found
   * in the source code.  Freezing generic names does not automatically
   * freeze specific names unless the names are the same.
   */

  func_type = A_INTR;
  switch (intast) {
  case I_ICHAR:
    if (count == 2) {
      count = 1;
    }
    func_ast = mk_id(sptre);
    break;
  case I_MODULO:
    switch ((int)INTTYPG(sptr)) {
    case DT_SINT:
      rtlRtn = RTE_imodulov;
      break;
    case DT_INT4:
      rtlRtn = RTE_modulov;
      break;
    case DT_INT8:
      rtlRtn = RTE_i8modulov;
      break;
    case DT_REAL4:
      rtlRtn = RTE_amodulov;
      break;
    case DT_REAL8:
      rtlRtn = RTE_dmodulov;
      break;
    }
    fsptr = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), (int)INTTYPG(sptr));
    EXTSYMP(sptr, fsptr);
    ELEMENTALP(sptr, 1);
    func_ast = mk_id(fsptr);
    break;
#ifdef I_C_ASSOCIATED
  case I_C_ASSOCIATED:
    if (_c_associated(stktop, count)) {
      count = 2;
      goto use_intr_sym;
    }
    goto intrinsic_error;
#endif
  case I_SNGL:
    if (XBIT(124, 0x8)) {
      /* -r8 */
      ast = ARG_AST(0);
      SST_ASTP(stktop, ast);
      SST_DTYPEP(stktop, DT_REAL8);
      SST_SHAPEP(stktop, shaper);
      EXPSTP(sptre, 1);
      return 1;
    }
    goto use_intr_sym;
  case I_IISHFTC:
  case I_JISHFTC:
  case I_ISHFTC:
  case I_KISHFTC:
    if (count == 2) { /* need to provide a size argument */
      ARG_AST(2) = mk_cval((INT)bits_in((int)DDTG(f_dt)), DT_INT);
      count++;
    }
  /*  fall thru  */
  default: /* name is just the name of the specific or generic */
  use_intr_sym:
    func_ast = mk_id(sptre);
    break;
  }

  argt = mk_argt(count); /* space for arguments */
  for (i = 0; i < count; i++)
    ARGT_ARG(argt, i) = ARG_AST(i);

  ast = mk_func_node(func_type, func_ast, count, argt);
  A_DTYPEP(ast, dtyper);
  A_OPTYPEP(ast, intast);
  A_SHAPEP(ast, shaper);
  SST_ASTP(stktop, ast);
  SST_SHAPEP(stktop, shaper);
  EXPSTP(sptre, 1);

  return 1;

/*
 * Error recovery: Generate ILM's, and fix semantic stack
 */
intrinsic_error:

  /* Need to add a check for min and max first */
  if (STYPEG(sptre) == ST_GENERIC && (intrin == I_MAX || intrin == I_MIN)) {
    if (count > 1 && ((DTY(dtype1) == TY_CHAR || DTY(dtype1) == TY_NCHAR) ||
                      (DTYG(dtype1) == TY_CHAR || DTYG(dtype1) == TY_NCHAR))) {

      /* Need to check if all arguments are the same type.
       * Not sure if we can check shape here, I think so(later).
       */
      argt = mk_argt(count + 2);
      for (i = 0; i < count; i++) {
        sp = ARG_STK(i);
        argdtype = SST_DTYPEG(sp);
        if (DTY(argdtype) != DTY(dtype1)) {
          goto intrinsic_error2;
        }
        if (ARG_AST(i)) {
          ARGT_ARG(argt, i + 2) = ARG_AST(i);
        } else if (SST_IDG(sp) == S_IDENT || SST_IDG(sp) == S_ACONST) {
          SST_ASTP(sp, 0);
          (void)mkarg(sp, &dum);
          XFR_ARGAST(i);
          ARGT_ARG(argt, i + 2) = ARG_AST(i);
          if (rank_of_ast((int)ARG_AST(0)) != rank_of_ast((int)ARG_AST(i))) {
            goto intrinsic_error2;
          }
        }
      }
      rtlRtn = intrin == I_MAX ? RTE_max : RTE_min;
      hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtyper);
      func_ast = mk_id(hpf_sym);
      /* Add 2 arguments
       * 1) the number of argument in the list, excluding itself and the result
       * 2) the result
       */
      sp = ARG_STK(0);
      chktyp(sp, dtype1, TRUE);
      shaper = SST_SHAPEG(sp);

      /* check only the first argument */
      if (DTY(dtype1) == TY_ARRAY) {
        if (shaper) {
          if (SHD_NDIM(shaper) != ADD_NUMDIM(dtype1)) {
            tmp = get_shape_arr_temp(ARG_AST(0));
          } else {
            ADSC *ad;
            ad = AD_DPTR(dtype1);
            if (AD_DEFER(ad) || AD_ADJARR(ad) || AD_NOBOUNDS(ad)) {
              tmp = get_shape_arr_temp(ARG_AST(0));
            } else
              tmp = get_arr_temp(dtype1, FALSE, TRUE, FALSE);
          }
        } else
          tmp = get_arr_temp(dtype1, FALSE, TRUE, FALSE);

      } else {
        dtype1 = get_temp_dtype(dtype1, ARG_AST(0));
        tmp = get_temp(dtype1);
      }
      tmp_ast = mk_id(tmp);

      func_type = A_CALL;
      /* First number of argument list, and a result */
      ARGT_ARG(argt, 0) = mk_cval(count, DT_INT);
      ARGT_ARG(argt, 1) = tmp_ast;

      ast = mk_func_node(func_type, func_ast, count + 2, argt);

      add_stmt(ast);
      dtyper = dtype1;
      A_DTYPEP(ast, dtyper);
      A_DTYPEP(func_ast, dtyper);
      A_SHAPEP(ast, shaper);

      SST_ASTP(stktop, tmp_ast);
      SST_SHAPEP(stktop, shaper);
      SST_DTYPEP(stktop, dtyper);
      SST_IDP(stktop, S_EXPR);

      EXPSTP(hpf_sym, 1);
      ELEMENTALP(hpf_sym, 1);
      return 1;
    }
  }

intrinsic_error2:
  /* Wrong number or type of arguments to intrinsic */
  if (frozen) {
    /* Replace expression term with constant 0.  Save sptr to intrinsic
     * in stack so that during lvalue processing the error message
     * generated can get the symbol's name.
     */
    error(74, 3, gbl.lineno, SYMNAME(sptre), CNULL);
    fix_term(stktop, stb.i0);
    SST_ERRSYMP(stktop, sptre);
  } else {
    /* Intrinsic name without argument list is assumed to be a variable
     * Intrinsic name with wrong argument list is assumed to be external
     */
    if (list == NULL) {
      sptr = newsym(sptre);
      STYPEP(sptre, ST_VAR);
    } else {
      sptr = newsym(sptre);
      STYPEP(sptre, ST_IDENT);
    }

    mkident(stktop);
    SST_SYMP(stktop, sptr);
    mkvarref(stktop, list);
  }

  SST_IDP(stktop, S_EXPR);
  return 1;
}

#ifdef I_C_ASSOCIATED
static int
_c_associated(SST *stkp, int count)
{
  int lop, rop;

  lop = ARG_AST(0);
  if (!is_iso_cptr(A_DTYPEG(lop)))
    return 0;
  lop = rewrite_cptr_references(lop);
  ARG_AST(0) = lop;
  if (count == 2) {
    rop = ARG_AST(1);
    if (!is_iso_cptr(A_DTYPEG(rop)))
      return 0;
    rop = rewrite_cptr_references(rop);
    ARG_AST(1) = rop;
  }
  return 1;
}
#endif

static void
e74_cnt(int sym, int cnt, int l, int u)
{
  char buf[64];

  buf[0] = '-';
  buf[1] = ' ';
  if (l == u)
    sprintf(buf + 2, "%d argument(s) present, %d argument(s) expected", cnt, l);
  else
    sprintf(buf + 2, "%d argument(s) present, %d-%d argument(s) expected", cnt,
            l, u);
  error(74, 3, gbl.lineno, SYMNAME(sym), buf);
}

static void
e74_arg(int sym, int pos, char *kwd)
{
  char buf[128];
  int i;
  int kwd_len;
  char *np;
  char *p, *q;

  if (sem.which_pass == 0)
    return;
  strcpy(buf, "- keyword argument ");
  if (kwd != NULL)
    strcat(buf, kwd);
  else {
    kwd = KWDARGSTR(sym);
    for (i = 0; TRUE; i++) {
      if (*kwd == '*' || *kwd == ' ')
        kwd++;
      if (*kwd == '#' || *kwd == '\0') {
        sprintf(buf + strlen(buf), "position %d", pos + 1);
        goto report_;
      }
      kwd_len = 0;
      for (np = kwd; TRUE; np++) {
        if (*np == ' ' || *np == '\0')
          break;
        kwd_len++;
      }
      if (i == pos)
        break;
      kwd = np;
    }
    p = kwd;
    q = buf + strlen(buf);
    while (kwd_len > 0) {
      *q++ = *p++;
      --kwd_len;
    }
    *q = 0;
  }
report_:
  error(74, 3, gbl.lineno, SYMNAME(sym), buf);
}

static int
gen_call_class_obj_size(int sptr)
{
  int ast;
  int argt;
  int arg;
  int func_ast;
  int hpf_sym;

  argt = mk_argt(1);
  if (SCG(sptr) == SC_DUMMY) {
    arg = get_type_descr_arg(gbl.currsub, sptr);
  } else {
    arg = SDSCG(sptr) ? SDSCG(sptr) : get_static_type_descriptor(sptr);
  }

  ARGT_ARG(argt, 0) = mk_id(arg);
  DESCUSEDP(sptr, 1);

  hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(RTE_class_obj_size), DT_INT8);
  func_ast = mk_id(hpf_sym);
  ast = mk_func_node(A_FUNC, func_ast, 1, argt);
  A_DTYPEP(ast, DT_INT8);
  return ast;
}

/* this flag disables an error message in mkexpr1 (semutil.c)
 * about assumed-size arrays */
int dont_issue_assumedsize_error = 0;

/** \brief Handle calls to Predeclared functions.
    \param stktop function to call
    \param list   arguments to pass to function
 */
int
ref_pd(SST *stktop, ITEM *list)
{
  INT con1, con2;
  INT num1[4];
  INT res[4];
  INT kanj[2];
  INT conval = 0;
  INT q0, qhalf;
  char ch;
  int dtype1, dtype2, dtyper, dtyper2;
  int count, opc;
  int numdim;
  INT val[4];
  ISZ_T iszval;
  int dum;
  ITEM *ip1;
  int ast, arg1, arg2;
  int argt;
  int argt_count, argt_extra;
  int i;
  ADSC *ad;
  SST *stkp, *stkp1, *stkp2;
  SST *dim;
  SST *mask;
  int shape1, shape2, shaper;
  int tmp;
  int hpf_sym; /* hpf-specific sptr, if special name required for
                * the predeclared for hpf
                */
  int func_type;
  int arrtmp_ast;
  char *name;
  char tmpnm[64];
  int func_ast;
  ACL *shape_acl;
  ACL *expracl;
  int sptr, fsptr, baseptr;
  LOGICAL is_whole, is_constant;
  int asumsz;
  int assumshp;
  int adjarr;
  int pvar;
  int nelems, eltype;
  char *sname = NULL;
  char verstr[140]; /*140, get_version_str returns max 128 char + pf90 prefix */
  FtnRtlEnum rtlRtn;
  SPTR pdsym = SST_SYMG(stktop);
  int pdtype = PDNUMG(pdsym);
  int is_real2_arg_error = 0;

/* any integer type, or hollerith, or, if -x 51 0x20 not set, real/double */
#define TYPELESS(dt)                     \
  (DT_ISINT(dt) || DTY(dt) == TY_HOLL || \
   (!XBIT(51, 0x20) && (DTY(dt) == TY_REAL || DTY(dt) == TY_DBLE)))

  dont_issue_assumedsize_error = 0;
  SST_CVLENP(stktop, 0);
  hpf_sym = 0;
  func_type = A_INTR;
  /* Count the number of arguments to function */
  count = 0;
  for (ip1 = list; ip1 != ITEM_END; ip1 = ip1->next) {
    count++;
    if (SST_IDG(ip1->t.stkp) == S_TRIPLE) {
      /* form is e1:e2:e3 */
      error(76, 3, gbl.lineno, SYMNAME(pdsym), CNULL);
      goto bad_args;
    }
  }

  argt_count = count;
  argt_extra = 0;
  shaper = 0;
  switch (pdtype) {
  case PD_and:
  case PD_eqv:
  case PD_neqv:
  case PD_or:
    /* Validate the number of arguments and their data types */
    if (count != 2 || get_kwd_args(list, count, KWDARGSTR(pdsym)))
      goto bad_args;
    dtype1 = SST_DTYPEG(ARG_STK(0));
    dtype2 = SST_DTYPEG(ARG_STK(1));
    if (!TYPELESS(dtype1) || !TYPELESS(dtype2))
      goto bad_args;

    /* Choose size of operation and thus the result from the argument
     * having the largest size.  Then cast both arguments to this size.
     */
    dtype1 = (size_of(dtype1) > 4) ? DT_DWORD : DT_WORD;
    dtype2 = (size_of(dtype2) > 4) ? DT_DWORD : DT_WORD;
    dtyper = (dtype1 > dtype2) ? dtype1 : dtype2;
    (void)casttyp(ARG_STK(0), dtyper);
    (void)casttyp(ARG_STK(1), dtyper);
    XFR_ARGAST(0);
    XFR_ARGAST(1);
    break;

  case PD_compl:
    /* Validate the number of arguments and their data types */
    if (count != 1 || get_kwd_args(list, count, KWDARGSTR(pdsym)))
      goto bad_args;
    dtype1 = SST_DTYPEG(ARG_STK(0));

    if (!TYPELESS(dtype1))
      goto bad_args;

    /* Choose size of operation and thus result from the argument */
    if (size_of(dtype1) > 4) {
      (void)casttyp(ARG_STK(0), DT_DWORD);
      dtyper = DT_DWORD;
    } else {
      (void)casttyp(ARG_STK(0), DT_WORD);
      dtyper = DT_WORD;
    }
    XFR_ARGAST(0);
    break;

  case PD_zext:
  case PD_jzext:
    if (count != 1 || get_kwd_args(list, count, KWDARGSTR(pdsym)))
      goto bad_args;
    dtype1 = SST_DTYPEG(ARG_STK(0));
    if (!DT_ISINT(dtype1) && !DT_ISLOG(dtype1))
      goto bad_args;
    (void)mkexpr(ARG_STK(0));
    XFR_ARGAST(0);
    dtyper = DT_INT;
    break;
  case PD_izext:
    if (count != 1 || get_kwd_args(list, count, KWDARGSTR(pdsym)))
      goto bad_args;
    dtype1 = SST_DTYPEG(ARG_STK(0));
    if (!DT_ISINT(dtype1) && !DT_ISLOG(dtype1))
      goto bad_args;
    if (size_of(dtype1) > size_of(DT_SINT))
      goto bad_args;
    (void)mkexpr(ARG_STK(0));
    XFR_ARGAST(0);
    dtyper = DT_SINT;
    break;

  case PD_matmul:
    if (count != 2) {
      E74_CNT(pdsym, count, 2, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;

    stkp1 = ARG_STK(0); /* matrix_a */
    dtyper = SST_DTYPEG(stkp1);
    shape1 = SST_SHAPEG(stkp1);
    if (shape1 == 0) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    ast = SST_ASTG(stkp1);
    sptr = SST_SYMG(stkp1);

    stkp = ARG_STK(1); /* matrix_b */
    dtype2 = SST_DTYPEG(stkp);
    shape2 = SST_SHAPEG(stkp);
    if (shape2 == 0) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }

    /* Recognize and rewrite the idiom MATMUL(TRANSPOSE(...), ...).  At
     * present, we only handle the matrix by vector case for real and
     * complex.  This is an attempt to improve the performance of spec
     * benchmark galgel.
     */
    if (SST_IDG(stkp1) == S_EXPR && A_TYPEG(ast) == A_INTR)
      if (STYPEG(sptr) == ST_PD && PDNUMG(sptr) == PD_transpose)
        if (SHD_NDIM(shape1) == 2 && SHD_NDIM(shape2) == 1)
          if (DT_ISREAL_ARR(dtyper) || DT_ISCMPLX_ARR(dtyper))
            if (DTYG(dtyper) == DTYG(dtype2)) {

              pdsym = getsymbol("matmul_transpose");
              ARG_AST(0) = ARGT_ARG(A_ARGSG(ast), 0);
              /*SST_ASTP(stkp, A_LOPG(ast));*/
            }

    if (DT_ISLOG(DTY(dtyper + 1))) {
      if (!DT_ISLOG(DTY(dtype2 + 1))) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    } else if (DT_ISNUMERIC(DTY(dtyper + 1))) {
      if (!DT_ISNUMERIC(DTY(dtype2 + 1))) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    }

    switch (SHD_NDIM(shape1)) {
    case 1:
      if (SHD_NDIM(shape2) != 2) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
      /* (n) * (n, k) = (k) */
      /* TBD: cmp_bnd_shape(shape1, 1, shape2, 1) */
      add_shape_rank(1);
      add_shape_spec((int)SHD_LWB(shape2, 1), (int)SHD_UPB(shape2, 1),
                     (int)SHD_STRIDE(shape2, 1));
      break;
    case 2:
      switch (SHD_NDIM(shape2)) {
      case 1: /* (n, m) * (m) = (n) */
        /* TBD: cmp_bnd_shape(shape1, 2, shape2, 1) */
        add_shape_rank(1);
        add_shape_spec((int)SHD_LWB(shape1, 0), (int)SHD_UPB(shape1, 0),
                       (int)SHD_STRIDE(shape1, 0));
        break;
      case 2: /* (n, m) * (m, k) = (n, k) */
        /* TBD: cmp_bnd_shape(shape1, 2, shape2, 1) */
        add_shape_rank(2);
        add_shape_spec((int)SHD_LWB(shape1, 0), (int)SHD_UPB(shape1, 0),
                       (int)SHD_STRIDE(shape1, 0));
        add_shape_spec((int)SHD_LWB(shape2, 1), (int)SHD_UPB(shape2, 1),
                       (int)SHD_STRIDE(shape2, 1));
        break;
      default:
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
      break;
    default:
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    shaper = mk_shape();

    /* check data types with respect to the rules of the equivalent binary
     * operations.
     */
    if (DTY(dtyper + 1) < DTY(dtype2 + 1)) {
      cngtyp(ARG_STK(0), dtype2);
      dtyper = dtype2;
      XFR_ARGAST(0);
    } else {
      cngtyp(ARG_STK(1), dtyper);
      XFR_ARGAST(1);
    }
    break;
  case PD_dotproduct:
    if (!XBIT(49, 0x40)) /* if xbit set, CM fortran intrinsics allowed */
      goto bad_args;
  case PD_dot_product:
    if (count != 2) {
      E74_CNT(pdsym, count, 2, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    argt_count = 2;
    dtype1 = SST_DTYPEG(ARG_STK(0));
    if (DTY(dtype1) != TY_ARRAY || rank_of_ast(ARG_AST(0)) != 1) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    dtype2 = SST_DTYPEG(ARG_STK(1));
    if (DTY(dtype2) != TY_ARRAY || rank_of_ast(ARG_AST(1)) != 1) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    dtyper = DTY(dtype1 + 1);
    if (DT_ISLOG(dtyper)) {
      if (!DT_ISLOG(DTY(dtype2 + 1))) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    } else if (DT_ISNUMERIC(DTY(dtyper))) {
      if (!DT_ISNUMERIC(DTY(dtype2 + 1))) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    } else {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }

    /* check data types with respect to the rules of the equivalent binary
     * operations.
     */
    if (dtyper < DTY(dtype2 + 1)) {
      cngtyp(ARG_STK(0), dtype2);
      dtyper = DTY(dtype2 + 1);
      XFR_ARGAST(0);
    } else {
      cngtyp(ARG_STK(1), dtype1);
      XFR_ARGAST(1);
    }
    if (pdtype == PD_dotproduct) {
      INTASTP(pdsym, I_DOT_PRODUCT);
      if (flg.standard)
        ERR170("dotproduct should be dot_product");
    }
    break;
  case PD_all:
  case PD_any:
    if (count == 0 || count > 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    argt_count = 2;
    dtype1 = SST_DTYPEG(ARG_STK(0));
    if (!DT_ISLOG_ARR(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    dtyper = DTY(dtype1 + 1);
    if ((stkp = ARG_STK(1))) { /* dim */
      dtype2 = SST_DTYPEG(stkp);
      if (!DT_ISINT(dtype2)) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
      shaper = reduc_shape((int)A_SHAPEG(ARG_AST(0)), (int)SST_ASTG(stkp),
                           (int)STD_PREV(0));
      if (shaper)
        dtyper = dtype1;
    }
    break;
  case PD_count:
    if (count == 0 || count > 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    argt_count = 2;
    dtype1 = SST_DTYPEG(ARG_STK(0));
    if (!DT_ISLOG_ARR(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    dtyper = stb.user.dt_int;

    if ((stkp = ARG_STK(1))) { /* dim */
      dtype2 = SST_DTYPEG(stkp);
      if (!DT_ISINT(dtype2)) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
      shaper = reduc_shape((int)A_SHAPEG(ARG_AST(0)), (int)SST_ASTG(stkp),
                           (int)STD_PREV(0));
      if (shaper)
        dtyper = aux.dt_iarray;
    }
    break;
  case PD_findloc:
    if (count < 2 || count > 6) {
      E74_CNT(pdsym, count, 1, 6);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 6, KWDARGSTR(pdsym)))
      goto exit_;

    argt_count = 5;
    stkp = ARG_STK(0);
    dtype1 = SST_DTYPEG(stkp);
    if (!DT_ISNUMERIC_ARR(dtype1) &&
        !(DTY(dtype1) == TY_ARRAY &&
          (DTYG(dtype1) == TY_CHAR || DTYG(dtype1) == TY_NCHAR))) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    stkp = ARG_STK(1); /* value */
    dtype2 = SST_DTYPEG(stkp);
    if ((DT_ISNUMERIC_ARR(dtype1) && !DT_ISNUMERIC(dtype2)) ||
        DTYG(dtype1) !=
            DTYG(dtype2)) { // TODO: check type against input array ???
      E74_ARG(pdsym, 2, NULL);
      goto call_e74_arg;
    }

    if ((stkp = ARG_STK(4)) && SST_IDG(stkp) == S_CONST) { /* KIND */
      dtyper2 = set_kind_result(stkp, DT_INT, TY_INT);
      if (!dtyper2) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
    } else {
      dtyper2 = 0;
    }

    dim = 0;
    mask = 0;

    if ((stkp = ARG_STK(2))) {
      dtype2 = DDTG(SST_DTYPEG(stkp));
      if (DT_ISLOG(dtype2)) {
        /* mask && no dim */
        mask = stkp;
        ARG_STK(2) = 0;
      } else if (DT_ISINT(dtype2)) {
        dim = stkp;
      } else {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
    }

    if (dim) {
      ARG_STK(2) = dim;
      shaper = reduc_shape((int)A_SHAPEG(ARG_AST(0)), (int)SST_ASTG(stkp),
                           (int)STD_PREV(0));
      if (shaper)
        dtyper = aux.dt_iarray;
      else
        dtyper = (!dtyper2) ? stb.user.dt_int : dtyper2;
      XFR_ARGAST(2);
    } else {
      dtyper = get_array_dtype(1, (!dtyper2) ? stb.user.dt_int : dtyper2);
      ad = AD_DPTR(dtyper);
      AD_UPBD(ad, 0) = AD_UPAST(ad, 0) =
          mk_isz_cval(rank_of_ast(ARG_AST(0)), astb.bnd.dtype);
      ARG_AST(2) = 0;
    }

    if ((stkp = ARG_STK(3))) {
      dtype2 = DDTG(SST_DTYPEG(stkp));
      if (!DT_ISLOG(dtype2) || mask) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
      mask = ARG_STK(3);
    }

    if (mask) {
      ARG_STK(3) = mask;
      if (!chkshape(mask, ARG_STK(0), FALSE)) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
      ARG_AST(3) = SST_ASTG(mask);
    }

    /* back */
    if ((stkp = ARG_STK(5))) {
      dtype2 = DDTG(SST_DTYPEG(stkp));
      if (!DT_ISLOG(dtype2)) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
      ARG_AST(4) = SST_ASTG(ARG_STK(5));
    } else {
      ARG_AST(4) = mk_cval(SCFTN_FALSE, DT_LOG);
    }
    break;

  case PD_minloc:
  case PD_maxloc:
    if (count == 0 || count > 4) {
      E74_CNT(pdsym, count, 1, 4);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 4, KWDARGSTR(pdsym)))
      goto exit_;

    if ((stkp = ARG_STK(3))) { /* KIND */
      dtyper2 = set_kind_result(stkp, DT_INT, TY_INT);
      if (!dtyper2) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
    } else {
      dtyper2 = 0;
    }

    /* back */
    if ((stkp = ARG_STK(4))) {
      dtype2 = DDTG(SST_DTYPEG(stkp));
      if (!DT_ISLOG(dtype2)) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
      ARG_AST(3) = SST_ASTG(ARG_STK(4));
    } else {
      ARG_AST(3) = mk_cval(SCFTN_FALSE, DT_LOG);
    }

    stkp = ARG_STK(0);
    argt_count = 4;
    dtype1 = SST_DTYPEG(stkp);
    if (!DT_ISNUMERIC_ARR(dtype1) &&
        !(DTY(dtype1) == TY_ARRAY &&
          (DTYG(dtype1) == TY_CHAR || DTYG(dtype1) == TY_NCHAR))) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if ((stkp = ARG_STK(2))) { /* mask */
      dtype2 = DDTG(SST_DTYPEG(stkp));
      if (!DT_ISLOG(dtype2)) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
      if (!chkshape(stkp, ARG_STK(0), FALSE)) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
      XFR_ARGAST(2);
    }
    if ((stkp = ARG_STK(1))) { /* dim */
      dtype2 = SST_DTYPEG(stkp);
      if (count == 2 && DT_ISLOG(DDTG(dtype2)) &&
          chkshape(stkp, ARG_STK(0), FALSE)) {
        XFR_ARGAST(1);
        /* shift args over */
        ARG_AST(2) = ARG_AST(1); /* mask */
        ARG_AST(1) = 0;          /* dim is 'null' */
        goto minloc_nodim;
      }
      if (!DT_ISINT(dtype2)) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
      shaper = reduc_shape((int)A_SHAPEG(ARG_AST(0)), (int)SST_ASTG(stkp),
                           (int)STD_PREV(0));
      if (shaper)
        dtyper = aux.dt_iarray;
      else
        dtyper = (!dtyper2) ? stb.user.dt_int : dtyper2;
    } else {
    minloc_nodim:
      dtyper = get_array_dtype(1, (!dtyper2) ? stb.user.dt_int : dtyper2);
      ad = AD_DPTR(dtyper);
      AD_UPBD(ad, 0) = AD_UPAST(ad, 0) =
          mk_isz_cval(rank_of_ast(ARG_AST(0)), astb.bnd.dtype);
    }
    break;
  case PD_minval:
  case PD_maxval:
  case PD_product:
  case PD_sum:
  case PD_norm2:
    if (count == 0 || count > 3) {
      E74_CNT(pdsym, count, 1, 3);
      goto call_e74_cnt;
    }

    // norm2 intrinsic does not have a mask arg
    argt_count = pdtype == PD_norm2 ? 2 : 3;
    if (evl_kwd_args(list, argt_count, KWDARGSTR(pdsym)))
      goto exit_;
    dtype1 = SST_DTYPEG(ARG_STK(0));
    if (!DT_ISNUMERIC_ARR(dtype1)) {
      if (pdtype == PD_minval || pdtype == PD_maxval) {
        if (!(DTY(dtype1) == TY_ARRAY &&
              (DTYG(dtype1) == TY_CHAR || DTYG(dtype1) == TY_NCHAR))) {
          E74_ARG(pdsym, 0, NULL);
          goto call_e74_arg;
        }

      } else {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
    }
    if (pdtype == PD_minval || pdtype == PD_maxval) {
      if ((!DT_ISINT_ARR(dtype1) && !DT_ISREAL_ARR(dtype1) &&
           !(DTY(dtype1) == TY_ARRAY &&
             (DTYG(dtype1) == TY_CHAR || DTYG(dtype1) == TY_NCHAR))) ||
          DT_ISLOG_ARR(dtype1)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
    }

    if (pdtype == PD_norm2) {
      if (!DT_ISREAL_ARR(dtype1)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
      if (ARG_STK(1)) {
        // dim arg
        ast = SST_ASTG(ARG_STK(1));
        sptr = ast_is_sym(ast) ? memsym_of_ast(ast) : 0;

        // If symbol, disallow if optional dummy arguments used as dim
        if (sptr && OPTARGG(sptr)) {
          E74_ARG(pdsym, 1, NULL);
          goto call_e74_arg;
        }
      }
    }

    dtyper = DTY(dtype1 + 1);
    if ((stkp = ARG_STK(2))) { /* mask */
      dtype2 = DDTG(SST_DTYPEG(stkp));
      if (!DT_ISLOG(dtype2)) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
      if (!chkshape(stkp, ARG_STK(0), FALSE)) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
      XFR_ARGAST(2);
    }
    if ((stkp = ARG_STK(1))) { /* dim */
      dtype2 = SST_DTYPEG(stkp);
      if (!DT_ISINT(dtype2)) {
        if (count == 2) {
          if (DT_ISLOG(DDTG(dtype2)) && chkshape(stkp, ARG_STK(0), FALSE)) {
            XFR_ARGAST(1);
            /* shift args over */
            ARG_AST(2) = ARG_AST(1); /* mask */
            ARG_AST(1) = 0;          /* dim is 'null' */
            break;
          }
        }
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }

      if (rank_of_ast(ARG_AST(0)) != 1) {
        shaper = reduc_shape((int)A_SHAPEG(ARG_AST(0)), (int)SST_ASTG(stkp),
                             (int)STD_PREV(0));
        if (shaper)
          dtyper = dtype1;
      } else
        check_dim_error((int)A_SHAPEG(ARG_AST(0)), (int)SST_ASTG(stkp));
    }
    break;
  case PD_dlbound:
    if (!XBIT(49, 0x40)) /* if xbit set, CM fortran intrinsics allowed */
      goto bad_args;
    pdtype = PD_lbound;
    goto lbound_ubound;
  case PD_dubound:
    if (!XBIT(49, 0x40)) /* if xbit set, CM fortran intrinsics allowed */
      goto bad_args;
    pdtype = PD_ubound;
  /*  fall thru  */
  case PD_lbound:
  case PD_ubound:
  lbound_ubound:
    if (count == 0 || count > 3) {
      E74_CNT(pdsym, count, 1, 3);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 3, KWDARGSTR(pdsym)))
      goto exit_;

    if ((stkp = ARG_STK(2))) { /* KIND */
      dtyper2 = set_kind_result(stkp, DT_INT, TY_INT);
      if (!dtyper2) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
    } else {
      dtyper2 = 0;
    }

    (void)mkarg(ARG_STK(0), &dum);
    XFR_ARGAST(0);
    argt_count = 2;
    dtype1 = SST_DTYPEG(ARG_STK(0));
    if (DTY(dtype1) != TY_ARRAY) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    if (sem.dinit_data) {
      int rank;
      int ubound[7];
      int lbound[7];
      SST bndarry;
      ACL *argacl;
      ACL **r;

      stkp = ARG_STK(0);
      ad = AD_DPTR(SST_DTYPEG(stkp));
      rank = AD_NUMDIM(
          ad); /* rank of array arg, potential upper bound of result array */

      for (i = 0; i < rank; i++) {
        ubound[i] = AD_UPAST(ad, i);
        lbound[i] = AD_LWAST(ad, i);
      }

      sem.arrdim.ndim = 1;
      sem.arrdim.ndefer = 0;
      sem.bounds[0].lowtype = S_CONST;
      sem.bounds[0].lowb = 1;
      sem.bounds[0].lwast = 0;
      sem.bounds[0].uptype = S_CONST;
      sem.bounds[0].upb = rank;
      sem.bounds[0].upast = mk_cval(rank, stb.user.dt_int);
      dtyper = mk_arrdsc();
      DTY(dtyper + 1) = (!dtyper2) ? stb.user.dt_int : dtyper2;

      argacl = GET_ACL(15);

      if (count == 2) {
        dtyper = stb.user.dt_int;
      }

      gen_init_intrin_call(stktop, pdsym, count, dtyper, FALSE);
      return 0;
    }

    shape1 = A_SHAPEG(ARG_AST(0));
    count = SHD_NDIM(shape1); /* rank of array arg */
    argt_count = count * 2 + 2;
    adjarr = 0;
    asumsz = 0;
    assumshp = 0;
    arg1 = ARG_AST(0);
    switch (A_TYPEG(arg1)) {
    case A_ID:
      adjarr = assumshp = asumsz = A_SPTRG(arg1);
      if (SCG(asumsz) != SC_DUMMY || !ASUMSZG(asumsz))
        asumsz = 0;
      if (SCG(assumshp) != SC_DUMMY || !ASSUMSHPG(assumshp))
        assumshp = 0;
      if (SCG(adjarr) != SC_DUMMY || !ADJARRG(adjarr))
        adjarr = 0;
      is_whole = TRUE;
      break;
    case A_MEM:
      if (A_SHAPEG(A_PARENTG(arg1))) {
        is_whole = FALSE;
      } else {
        is_whole = TRUE;
      }
      break;
    default:
      is_whole = FALSE;
      break;
    }
    sptr = find_pointer_variable(arg1);
    if (sptr && (POINTERG(sptr) || (ALLOCG(sptr) && SDSCG(sptr)))) {
      if ((stkp = ARG_STK(1))) {
        /* pghpf...bound(dim, static_desciptor) */
        (void)mkexpr(stkp);
        XFR_ARGAST(1);
        dtype2 = SST_DTYPEG(stkp);
        if (!DT_ISINT(dtype2)) {
          E74_ARG(pdsym, 1, NULL);
          goto call_e74_arg;
        }
        if (XBIT(68, 0x1) && XBIT(68, 0x2))
          dtyper = (!dtyper2) ? DT_INT8 : dtyper2;
        else
          dtyper = (!dtyper2) ? stb.user.dt_int : dtyper2;
        shaper = 0;
        ARG_AST(0) = mk_bnd_int(ARG_AST(1)); /* dim */
        ARG_AST(1) = check_member(arg1, mk_id(SDSCG(sptr)));
        /* static descriptor */
        func_type = A_FUNC;
        if (pdtype == PD_lbound) {
          switch (dtyper2) {
          case 0:
            rtlRtn = RTE_lboundDsc;
            break;
          case DT_BINT:
            rtlRtn = RTE_lbound1Dsc;
            break;
          case DT_SINT:
            rtlRtn = RTE_lbound2Dsc;
            break;
          case DT_INT4:
            rtlRtn = RTE_lbound4Dsc;
            break;
          case DT_INT8:
            rtlRtn = RTE_lbound8Dsc;
            break;
          default:
            error(155, 3, gbl.lineno, SYMNAME(gbl.currsub),
                  "invalid kind argument for ubound");
          }
        } else {
          switch (dtyper2) {
          case 0:
            rtlRtn = RTE_uboundDsc;
            break;
          case DT_BINT:
            rtlRtn = RTE_ubound1Dsc;
            break;
          case DT_SINT:
            rtlRtn = RTE_ubound2Dsc;
            break;
          case DT_INT4:
            rtlRtn = RTE_ubound4Dsc;
            break;
          case DT_INT8:
            rtlRtn = RTE_ubound8Dsc;
            break;
          default:
            error(155, 3, gbl.lineno, SYMNAME(gbl.currsub),
                  "invalid kind argument for lbound");
          }
        }

        /* FIXME: there is no [lu]bound[1234]*Dsc (ENTPGHPF)routines */
        if (XBIT(68, 0x1))
          hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn),
                                      (!dtyper2) ? dtyper : dtyper2);
        else
          hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn),
                                      (!dtyper2) ? dtyper : dtyper2);

        arrtmp_ast = 0;
        argt_count = 2;
        goto gen_call;
      }

      /* pghpf...bounda(temp, sd) */

      if (XBIT(68, 0x1) && XBIT(68, 0x2))
        dtyper = (!dtyper2) ? get_array_dtype(1, DT_INT8)
                            : get_array_dtype(1, dtyper2);
      else
        dtyper = (!dtyper2) ? get_array_dtype(1, stb.user.dt_int)
                            : get_array_dtype(1, dtyper2);
      ad = AD_DPTR(dtyper);
      AD_UPBD(ad, 0) = AD_UPAST(ad, 0) =
          mk_isz_cval(rank_of_ast(ARG_AST(0)), astb.bnd.dtype);
      tmp = get_arr_temp(dtyper, FALSE, FALSE, FALSE);
      arrtmp_ast = mk_id(tmp);
      shaper = A_SHAPEG(arrtmp_ast);
      ARG_AST(0) = arrtmp_ast; /* first argument is temp */
      ARG_AST(1) = check_member(arg1, mk_id(SDSCG(sptr)));
      /* static descriptor */
      func_type = A_CALL;
      if (!XBIT(68, 0x1) || XBIT(68, 0x2)) {
        if (pdtype == PD_lbound) {
          switch (dtyper2) {
          case 0:
            rtlRtn = RTE_lboundaDsc;
            break;
          case DT_BINT:
            rtlRtn = RTE_lbounda1Dsc;
            break;
          case DT_SINT:
            rtlRtn = RTE_lbounda2Dsc;
            break;
          case DT_INT4:
            rtlRtn = RTE_lbounda4Dsc;
            break;
          case DT_INT8:
            rtlRtn = RTE_lbounda8Dsc;
            break;
          default:
            error(155, 3, gbl.lineno, SYMNAME(gbl.currsub),
                  "invalid kind argument for lbound");
          }
        } else {
          switch (dtyper2) {
          case 0:
            rtlRtn = RTE_uboundaDsc;
            break;
          case DT_BINT:
            rtlRtn = RTE_ubounda1Dsc;
            break;
          case DT_SINT:
            rtlRtn = RTE_ubounda2Dsc;
            break;
          case DT_INT4:
            rtlRtn = RTE_ubounda4Dsc;
            break;
          case DT_INT8:
            rtlRtn = RTE_ubounda8Dsc;
            break;
          default:
            error(155, 3, gbl.lineno, SYMNAME(gbl.currsub),
                  "invalid kind argument for ubound");
          }
        }
      } else {
        /* -Mlarge_arrays, but the result is default integer */
        if (pdtype == PD_lbound) {
          switch (dtyper2) {
          case 0:
            rtlRtn = RTE_lboundazDsc;
            break;
          case DT_BINT:
            rtlRtn = RTE_lboundaz1Dsc;
            break;
          case DT_SINT:
            rtlRtn = RTE_lboundaz2Dsc;
            break;
          case DT_INT4:
            rtlRtn = RTE_lboundaz4Dsc;
            break;
          case DT_INT8:
            rtlRtn = RTE_lboundaz8Dsc;
            break;
          default:
            error(155, 3, gbl.lineno, SYMNAME(gbl.currsub),
                  "invalid kind argument for lbound");
          }
        } else {
          switch (dtyper2) {
          case 0:
            rtlRtn = RTE_uboundazDsc;
            break;
          case DT_BINT:
            rtlRtn = RTE_uboundaz1Dsc;
            break;
          case DT_SINT:
            rtlRtn = RTE_uboundaz2Dsc;
            break;
          case DT_INT4:
            rtlRtn = RTE_uboundaz4Dsc;
            break;
          case DT_INT8:
            rtlRtn = RTE_uboundaz8Dsc;
            break;
          default:
            error(155, 3, gbl.lineno, SYMNAME(gbl.currsub),
                  "invalid kind argument for ubound");
          }
        }
      }

      hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), DT_NONE);
      ast = begin_call(func_type, hpf_sym, 2);
      add_arg(ARG_AST(0));
      add_arg(ARG_AST(1));
      /* call statement is generated, result is the temporary */
      (void)add_stmt(ast);
      ast = arrtmp_ast;
      goto expr_val;
    }

    if ((stkp = ARG_STK(1))) {
      /* f90...bound(rank, dim, l1, u1, l1, u2, ..., l<rank>, u<rank>) */
      (void)mkexpr(stkp);
      XFR_ARGAST(1);
      dtype2 = SST_DTYPEG(stkp);
      if (!DT_ISINT(dtype2)) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
      if (XBIT(68, 0x1) && XBIT(68, 0x2))
        dtyper = (!dtyper2) ? DT_INT8 : dtyper2;
      else
        dtyper = (!dtyper2) ? stb.user.dt_int : dtyper2;
      shaper = 0;
      if ((ast = A_ALIASG(ARG_AST(1)))) {
        /* dim is a constant */
        i = get_int_cval(A_SPTRG(ast));
        if (i < 1 || i > count) {
          error(423, 3, gbl.lineno, NULL, NULL);
          i = 1;
        }
        if (pdtype == PD_lbound) {
          if (is_whole) {
            if (asumsz != 0 && i == count)
              ast = astb.bnd.one;
            else {
              ast = lbound_of_shape(shape1, i - 1);
              if (ast == 0 && SHD_LWB(shape1, i - 1)) {
                ast = SHD_LWB(shape1, i - 1);
              }
            }
          } else
            ast = astb.bnd.one;
        } else { /* ubound/dubound */
          if (is_whole) {
            if (asumsz != 0 && i == count) {
              error(84, 3, gbl.lineno, SYMNAME(asumsz),
                    "- ubound of assumed size array is unknown");
              ast = astb.bnd.one;
            } else {
              ast = ubound_of_shape(shape1, i - 1);
              if (ast == 0 && SHD_UPB(shape1, i - 1)) {
                ast = SHD_UPB(shape1, i - 1);
              }
            }
          }
          /*
           * Before computing the extent, ensure that an upper bound
           * for this dimension exists.  The upper bound may be zero
           * if the array is an argument declared in an interface
           * within a module.
           */
          else if (SHD_UPB(shape1, i - 1)) {
            ast = extent_of_shape(shape1, i - 1);
            goto expr_val;
          } else
            ast = 0;
        }
        if (ast) {
          if (A_ALIASG(ast)) {
            ast = A_ALIASG(ast);
            iszval = get_isz_cval(A_SPTRG(ast));
            goto const_isz_val;
          }
          if (A_DTYPEG(ast) != dtyper)
            ast = mk_convert(ast, dtyper);
        }
        if (pdtype == PD_lbound) {
          switch (dtyper2) {
          case 0:
            rtlRtn = RTE_lb;
            break;
          case DT_BINT:
            rtlRtn = RTE_lb1;
            break;
          case DT_SINT:
            rtlRtn = RTE_lb2;
            break;
          case DT_INT4:
            rtlRtn = RTE_lb4;
            break;
          case DT_INT8:
            rtlRtn = RTE_lb8;
            break;
          default:
            error(155, 3, gbl.lineno, SYMNAME(gbl.currsub),
                  "invalid kind argument for lbound");
          }
        } else {
          switch (dtyper2) {
          case 0:
            rtlRtn = RTE_ub;
            break;
          case DT_BINT:
            rtlRtn = RTE_ub1;
            break;
          case DT_SINT:
            rtlRtn = RTE_ub2;
            break;
          case DT_INT4:
            rtlRtn = RTE_ub4;
            break;
          case DT_INT8:
            rtlRtn = RTE_ub8;
            break;
          default:
            error(155, 3, gbl.lineno, SYMNAME(gbl.currsub),
                  "invalid kind argument for ubound");
          }
        }
        if (adjarr != 0) {
          /* If this expression uses an adjustable dummy array, then
           * generate the intrinsic lbound/ubound call instead of a rewritten
           * bound function call.
           * Otherwise, the call may be wrongfully placed in an early
           * specification statement. This intrinsic call may be rewritten later
           * but after we handle the early specification statements.
           */
          argt_count = 2;
          goto gen_call;
        }
        if (sem.interface || (assumshp != 0 && sem.which_pass == 0)) {
          /*
           * if this expression is rewritten (i.e., when this
           * function specified by this interface is invoked),
           * ast_rewrite() will select the bound based on the
           * constant dim value.
           */
          argt_count = 2;

          (void)sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), stb.user.dt_int);
          goto gen_call;
        }
        /* ast is 0 => must determine the bound based on the lower and
         * upper bound of the specified dimension; call the function
         * with (rank = 1, dim = 1, lb<dim>, ub<dim>).
         */
        if (assumshp != 0 && sem.which_pass != 0) {
          if (pdtype == PD_lbound) {
            ast = SHD_LWB(shape1, i - 1);
            if (A_TYPEG(ast) == A_CNST && get_int_cval(A_SPTRG(ast)) != 1) {
              /* assumed shape array with a constant lb != 1
               * dpm_out.c:set_assumed_bounds my reset the
               * lb as per the F90 Standard section 13.13.52.
               * The following insures that the correct lb
               * is reported.
               */
              ast = ADD_LWAST(dtype1, i - 1);
            }
          } else {
            ast = SHD_UPB(shape1, i - 1);
          }
          if (ast) {
            if (A_DTYPEG(ast) != dtyper)
              ast = mk_convert(ast, dtyper);
            goto lbound_ret;
          }
        }

        hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtyper);
        ast = begin_call(A_FUNC, hpf_sym, 4);
        add_arg(astb.bnd.one);
        add_arg(astb.bnd.one);
        add_arg(check_member(arg1, SHD_LWB(shape1, i - 1)));
        add_arg(check_member(arg1, SHD_UPB(shape1, i - 1)));
        A_DTYPEP(ast, dtyper);
        goto lbound_ret;
      }
      ARG_AST(0) = mk_isz_cval((INT)count, astb.bnd.dtype); /* rank */
      /* ARG_AST(1) = ARG_AST(1);			   dim */
      func_type = A_FUNC;
      if (pdtype == PD_lbound)
        rtlRtn = RTE_lb;
      else {
        if (asumsz != 0 && count == 1)
          error(84, 3, gbl.lineno, SYMNAME(asumsz),
                "- ubound of assumed size array is unknown");
        rtlRtn = RTE_ub;
      }

      hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtyper);
      arrtmp_ast = 0;
    } else {
      /*f90...bounda(temp, rank, l1, u1, l1, u2, ..., l<rank>, u<rank>) */
      if (XBIT(68, 0x1) && XBIT(68, 0x2))
        dtyper = (!dtyper2) ? get_array_dtype(1, DT_INT8)
                            : get_array_dtype(1, dtyper2);
      else
        dtyper = (!dtyper2) ? get_array_dtype(1, stb.user.dt_int)
                            : get_array_dtype(1, dtyper2);
      ad = AD_DPTR(dtyper);
      AD_UPBD(ad, 0) = AD_UPAST(ad, 0) =
          mk_isz_cval(rank_of_ast(ARG_AST(0)), astb.bnd.dtype);
      tmp = get_arr_temp(dtyper, FALSE, FALSE, FALSE);
      arrtmp_ast = mk_id(tmp);
      shaper = A_SHAPEG(arrtmp_ast);
      ARG_AST(0) = arrtmp_ast; /* first argument is temp */
      ARG_AST(1) = mk_isz_cval((INT)count, astb.bnd.dtype); /* rank */
      func_type = A_CALL;
      if (!XBIT(68, 0x1) || XBIT(68, 0x2)) {
        if (pdtype == PD_lbound) {
          switch (dtyper2) {
          case 0:
            rtlRtn = RTE_lba;
            break;
          case DT_BINT:
            rtlRtn = RTE_lba1;
            break;
          case DT_SINT:
            rtlRtn = RTE_lba2;
            break;
          case DT_INT4:
            rtlRtn = RTE_lba4;
            break;
          case DT_INT8:
            rtlRtn = RTE_lba8;
            break;
          default:
            error(155, 3, gbl.lineno, SYMNAME(gbl.currsub),
                  "invalid kind argument for lbound");
          }
        } else {
          if (asumsz != 0)
            error(84, 3, gbl.lineno, SYMNAME(asumsz),
                  "- ubound of assumed size array is unknown");
          switch (dtyper2) {
          case 0:
            rtlRtn = RTE_uba;
            break;
          case DT_BINT:
            rtlRtn = RTE_uba1;
            break;
          case DT_SINT:
            rtlRtn = RTE_uba2;
            break;
          case DT_INT4:
            rtlRtn = RTE_uba4;
            break;
          case DT_INT8:
            rtlRtn = RTE_uba8;
            break;
          default:
            error(155, 3, gbl.lineno, SYMNAME(gbl.currsub),
                  "invalid kind argument for ubound");
          }
        }
      } else {
        /* -Mlarge_arrays, but the result is default integer */
        if (pdtype == PD_lbound) {
          switch (dtyper2) {
          case 0:
            rtlRtn = RTE_lbaz;
            break;
          case DT_BINT:
            rtlRtn = RTE_lbaz1;
            break;
          case DT_SINT:
            rtlRtn = RTE_lbaz2;
            break;
          case DT_INT4:
            rtlRtn = RTE_lbaz4;
            break;
          case DT_INT8:
            rtlRtn = RTE_lbaz8;
            break;
          default:
            error(155, 3, gbl.lineno, SYMNAME(gbl.currsub),
                  "invalid kind argument for lbound");
          }
        } else {
          if (asumsz != 0)
            error(84, 3, gbl.lineno, SYMNAME(asumsz),
                  "- ubound of assumed size array is unknown");
          switch (dtyper2) {
          case 0:
            rtlRtn = RTE_ubaz;
            break;
          case DT_BINT:
            rtlRtn = RTE_ubaz1;
            break;
          case DT_SINT:
            rtlRtn = RTE_ubaz2;
            break;
          case DT_INT4:
            rtlRtn = RTE_ubaz4;
            break;
          case DT_INT8:
            rtlRtn = RTE_ubaz8;
            break;
          default:
            error(155, 3, gbl.lineno, SYMNAME(gbl.currsub),
                  "invalid kind argument for ubound");
          }
        }
      }

      hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), DT_NONE);
    }
    ast = begin_call(func_type, hpf_sym, argt_count);
    add_arg(ARG_AST(0));
    add_arg(ARG_AST(1));
    for (i = 0; i < count; i++) {
      if (is_whole) {
        if (assumshp != 0 && A_TYPEG(SHD_LWB(shape1, i)) == A_CNST &&
            get_int_cval(A_SPTRG(SHD_LWB(shape1, i))) != 1) {
          /* assumed shape array with a constant lb != 1
           * dpm_out.c:set_assumed_bounds my reset the
           * lb as per the F90 Standard section 13.13.52.
           * The following insures that the correct lb
           * is reported.
           */
          add_arg(ADD_LWAST(dtype1, i));
        } else {
          add_arg(SHD_LWB(shape1, i));
        }
      } else {
        add_arg(mk_cval((INT)1, astb.bnd.dtype));
      }
      if (is_whole) {
        if (i < count - 1)
          add_arg(SHD_UPB(shape1, i));
        else if (asumsz != 0)
          add_arg(astb.ptr0);
        else
          add_arg(SHD_UPB(shape1, i));
      } else
        add_arg(extent_of_shape(shape1, i));
    }
    if (arrtmp_ast) {
      /* call statement is generated, result is the temporary */
      (void)add_stmt(ast);
      ast = arrtmp_ast;
    } else
      A_DTYPEP(ast, dtyper);
  lbound_ret:
    goto expr_val;

  case PD_cshift:
    if (XBIT(49, 0x40)) { /* if xbit set, CM fortran intrinsics allowed */
      argpos_t swap;
      if (count != 3) {
        E74_CNT(pdsym, count, 3, 3);
        goto call_e74_cnt;
      }
      if (evl_kwd_args(list, 3, "array dim shift"))
        goto exit_;
      /* array dim shift --> array shift dim */
      swap = sem.argpos[1];          /* dim */
      sem.argpos[1] = sem.argpos[2]; /* shift */
      sem.argpos[2] = swap;          /* dim */
    } else if (count < 2 || count > 3) {
      E74_CNT(pdsym, count, 2, 3);
      goto call_e74_cnt;
    } else if (evl_kwd_args(list, 3, KWDARGSTR(pdsym)))
      goto exit_;
    argt_count = 3;
    dtyper = SST_DTYPEG(ARG_STK(0));
    if (DTY(dtyper) != TY_ARRAY) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    shaper = A_SHAPEG(ARG_AST(0));

    if ((stkp = ARG_STK(2))) { /* dim */
      dtype2 = SST_DTYPEG(stkp);
      if (!DT_ISINT(dtype2) && !DT_ISLOG(dtype2)) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
    } else
      ARG_AST(2) = astb.i1;

    stkp = ARG_STK(1); /* shift */
    dtype1 = SST_DTYPEG(stkp);
    dtype2 = DDTG(dtype1);
    if (!DT_ISINT(dtype2) && !DT_ISLOG(dtype2)) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    if (DTY(dtype1) != TY_ARRAY ||
        rank_of_ast(ARG_AST(1)) == (SHD_NDIM(shaper) - 1))
      /* legal cases */;
    else {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    break;
  case PD_eoshift:
    if (XBIT(49, 0x40)) { /* if xbit set, CM fortran intrinsics allowed */
      argpos_t swap;
      if (count < 3 || count > 4) {
        E74_CNT(pdsym, count, 3, 4);
        goto call_e74_cnt;
      }
      if (evl_kwd_args(list, 4, "array dim shift *boundary"))
        goto exit_;
      /* array dim shift boundary --> array shift boundary dim */
      swap = sem.argpos[1];          /* dim */
      sem.argpos[1] = sem.argpos[2]; /* shift */
      sem.argpos[2] = sem.argpos[3]; /* boundary */
      sem.argpos[3] = swap;          /* dim */
    } else if (count < 2 || count > 4) {
      E74_CNT(pdsym, count, 2, 4);
      goto call_e74_cnt;
    } else if (evl_kwd_args(list, 4, KWDARGSTR(pdsym)))
      goto exit_;
    argt_count = 4;
    dtyper = SST_DTYPEG(ARG_STK(0));
    if (DTY(dtyper) != TY_ARRAY) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    shaper = A_SHAPEG(ARG_AST(0));

    if ((stkp = ARG_STK(3))) { /* dim */
      dtype2 = SST_DTYPEG(stkp);
      if (!DT_ISINT(dtype2) && !DT_ISLOG(dtype2)) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
    } else
      ARG_AST(3) = astb.i1;

    stkp = ARG_STK(1); /* shift */
    dtype1 = SST_DTYPEG(stkp);
    dtype2 = DDTG(dtype1);
    if (!DT_ISINT(dtype2) && !DT_ISLOG(dtype2)) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    if (DTY(dtype1) != TY_ARRAY ||
        rank_of_ast(ARG_AST(1)) == (SHD_NDIM(shaper) - 1))
      /* legal cases */;
    else {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }

    if ((stkp = ARG_STK(2))) { /* boundary */
      dtype1 = SST_DTYPEG(stkp);
      dtype2 = DDTG(dtype1);
      if (dtype2 != DDTG(dtyper)) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
      if (DTY(dtype1) != TY_ARRAY ||
          rank_of_ast(ARG_AST(2)) == (SHD_NDIM(shaper) - 1))
        /* legal cases */;
      else {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
    }
    break;
  case PD_number_of_processors:
    if (count > 1) {
      E74_CNT(pdsym, count, 0, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    dtyper = stb.user.dt_int;
    if ((stkp = ARG_STK(0))) { /* dim */
      dtype1 = SST_DTYPEG(stkp);
      if (!DT_ISINT(dtype1)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }

      hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(RTE_number_of_processors),
                                  stb.user.dt_int);
      argt_count = 2;
      ARG_AST(1) = mk_cval(size_of(dtype1), DT_INT);
      break;
    }
    /* something hpf-specific here. */
    hpf_sym = sym_mknproc();
    ast = mk_id(hpf_sym);
    SST_IDP(stktop, S_EXPR);
    SST_DTYPEP(stktop, dtyper);
    SST_SHAPEP(stktop, 0);
    SST_ASTP(stktop, ast);
    return 1;
  case PD_ran:
    if (count != 1)
      goto bad_args;
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto bad_args;
    if (!is_varref(ARG_STK(0)) || SST_DTYPEG(ARG_STK(0)) != DT_INT) {
      goto bad_args;
    }
    (void)mkarg(ARG_STK(0), &dum);
    dtyper = stb.user.dt_real;
    XFR_ARGAST(0);
    sptr = sym_of_ast(ARG_AST(0)); /*  intent OUT arg */
    ADDRTKNP(sptr, 1);
    break;
  case PD_secnds:
    if (count != 1) {
      goto bad_args;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto bad_args;
    dtype1 = SST_DTYPEG(ARG_STK(0));
    if (dtype1 == DT_FLOAT) {
      (void)mkexpr(ARG_STK(0));
      dtyper = DT_FLOAT;
    } else if (dtype1 == DT_DBLE) {
      (void)mkexpr(ARG_STK(0));
      dtyper = DT_DBLE;
    } else {
      goto bad_args;
    }
    XFR_ARGAST(0);
    break;
  case PD_shift:
    /* Validate the number of arguments and their data types */
    if (count != 2)
      goto bad_args;
    if (get_kwd_args(list, count, KWDARGSTR(pdsym)))
      goto bad_args;
    dtyper = SST_DTYPEG(ARG_STK(0));
    if (!TYPELESS(dtyper) || !DT_ISINT(SST_DTYPEG(ARG_STK(1)))) {
      goto bad_args;
    }
    /*
       Choose size of operation and thus the result from the first
     * argument having the largest size.  Then cast first argument
     * to this size.
     */
    dtyper = (size_of(dtyper) > 4) ? DT_DWORD : DT_WORD;
    (void)casttyp(ARG_STK(0), dtyper);
    XFR_ARGAST(0);
    (void)chktyp(ARG_STK(1), DT_INT, FALSE);
    XFR_ARGAST(1);
    break;
  case PD_transpose:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    dtyper = SST_DTYPEG(ARG_STK(0));
    shaper = A_SHAPEG(ARG_AST(0));
    if (shaper == 0 || SHD_NDIM(shaper) != 2) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    add_shape_rank(2);
    add_shape_spec((int)SHD_LWB(shaper, 1), (int)SHD_UPB(shaper, 1),
                   (int)SHD_STRIDE(shaper, 1));
    add_shape_spec((int)SHD_LWB(shaper, 0), (int)SHD_UPB(shaper, 0),
                   (int)SHD_STRIDE(shaper, 0));
    shaper = mk_shape();
    break;
  case PD_spread:
    if (count != 3) {
      E74_CNT(pdsym, count, 3, 3);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 3, KWDARGSTR(pdsym)))
      goto exit_;

    stkp = ARG_STK(0); /* source */
    shape1 = SST_SHAPEG(stkp);
    if (shape1 && SHD_NDIM(shape1) == 7) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    dtype1 = SST_DTYPEG(stkp);
    /* assertion: it shouldn't matter that the result dtype doesn't have
     * the correct number of bounds.
     */
    dtyper = get_array_dtype(1, (int)DDTG(dtype1));

    if (!DT_ISINT(SST_DTYPEG(ARG_STK(2)))) { /* ncopies */
      E74_ARG(pdsym, 2, NULL);
      goto call_e74_arg;
    }

    stkp = ARG_STK(1); /* dim */
    dtype2 = SST_DTYPEG(stkp);
    if (!DT_ISINT(dtype2)) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }

    /* store max(ncopies, 0) into temporay */

    tmp = getcctmp_sc('d', sem.dtemps++, ST_VAR, DT_INT, sem.sc);
    i = ast_intr(I_MAX, DT_INT, 2, (int)ARG_AST(2), astb.i0);
    ast = mk_assn_stmt(mk_id(tmp), i, DT_INT);
    (void)add_stmt(ast);

    shaper = increase_shape(shape1, (int)SST_ASTG(stkp), mk_id(tmp),
                            (int)STD_PREV(0));
    break;
  case PD_pack:
    if (count < 2 || count > 3) {
      E74_CNT(pdsym, count, 2, 3);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 3, KWDARGSTR(pdsym)))
      goto exit_;
    argt_count = 3;

    stkp = ARG_STK(0); /* array */
    dtyper = SST_DTYPEG(stkp);
    if (DTY(dtyper) != TY_ARRAY) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    shape1 = SST_SHAPEG(stkp);

    stkp = ARG_STK(1); /* mask */
    dtype2 = SST_DTYPEG(stkp);
    if (!DT_ISLOG(DDTG(dtype2))) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    if (!chkshape(stkp, ARG_STK(0), FALSE)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    if (A_TYPEG(SST_ASTG(stkp)) != A_ID && DTY(dtype2) == TY_ARRAY) {
      /*
         Compute mask into a temp array and use this temp as the argument
         - first we need a dtype for the temp
       */
      int tmp_dtype = dtype2;

      ad = AD_DPTR(dtype2);

      if (!AD_NUMDIM(ad)) {
        tmp_dtype = dtype_with_shape(dtype2, A_SHAPEG(SST_ASTG(stkp)));
      } else {
        tmp_dtype = dtype_with_shape(DDTG(dtype2), A_SHAPEG(SST_ASTG(stkp)));
      }

      tmp = get_arr_temp(tmp_dtype, FALSE, FALSE, FALSE);
      arrtmp_ast = mk_id(tmp);
      ast = mk_assn_stmt(arrtmp_ast, SST_ASTG(stkp), tmp_dtype);
      (void)add_stmt(ast);
      ARG_AST(1) = arrtmp_ast;
    } else {
      XFR_ARGAST(1);
    }

    if ((stkp = ARG_STK(2))) { /* vector */
      if (!eq_dtype(DDTG(SST_DTYPEG(stkp)), DTY(dtyper + 1))) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
      if (rank_of_ast((int)ARG_AST(2)) != 1) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
    }

    tmp = getcctmp_sc('d', sem.dtemps++, ST_VAR, astb.bnd.dtype, sem.sc);
    add_shape_rank(1);
    add_shape_spec(astb.bnd.one, mk_id(tmp), astb.bnd.one);
    shaper = mk_shape();

    if (stkp != NULL)
      /* use size of vector */
      ast = size_of_ast(ARG_AST(2));
    else if (DTY(dtype2) != TY_ARRAY)
      /* mask is a scalar; use size of array */
      ast = size_of_ast(ARG_AST(0));
    else {
      /* else compute size by the expression  'count(mask)' */
      int t1;
      t1 = mk_argt(2);              /* space for arguments */
      ARGT_ARG(t1, 0) = ARG_AST(1); /* mask */
      ARGT_ARG(t1, 1) = 0;          /* no dim argument */

      func_ast = mk_id(intast_sym[I_COUNT]);
      ast = mk_func_node(A_INTR, func_ast, 2, t1);
      A_DTYPEP(ast, DT_INT);
      A_OPTYPEP(ast, I_COUNT);
      A_SHAPEP(ast, 0);
    }
    ast = mk_assn_stmt(mk_id(tmp), ast, DT_INT);
    (void)add_stmt(ast);
    break;
  case PD_unpack:
    if (count != 3) {
      E74_CNT(pdsym, count, 3, 3);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 3, KWDARGSTR(pdsym)))
      goto exit_;

    stkp = ARG_STK(0); /* vector: any rank 1 array */
    dtyper = SST_DTYPEG(stkp);
    shape1 = SST_SHAPEG(stkp);
    if (DTY(dtyper) != TY_ARRAY || SHD_NDIM(shape1) != 1) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    stkp = ARG_STK(1); /* mask: logical array */
    dtype1 = SST_DTYPEG(stkp);
    shaper = SST_SHAPEG(stkp);
    if (!DT_ISLOG_ARR(dtype1)) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }

    stkp = ARG_STK(2);         /* field: same type as vector */
    dtype2 = SST_DTYPEG(stkp); /*        same shape as mask */
    shape2 = SST_SHAPEG(stkp);
    if (!eq_dtype(DDTG(dtype2), DTY(dtyper + 1))) {
      E74_ARG(pdsym, 2, NULL);
      goto call_e74_arg;
    }
    if (!chkshape(stkp, ARG_STK(1), FALSE)) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    XFR_ARGAST(2);
    break;
  case PD_dshape:
    if (!XBIT(49, 0x40)) /* if xbit set, CM fortran intrinsics allowed */
      goto bad_args;
  case PD_shape:
    if (count < 1 || count > 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;

    if ((stkp = ARG_STK(1))) { /* KIND */
      dtyper2 = set_kind_result(stkp, DT_INT, TY_INT);
      if (!dtyper2) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
    } else {
      dtyper2 = 0;
    }

    dtype1 = (!dtyper2) ? stb.user.dt_int : dtyper2;

    dtyper = get_array_dtype(1, dtype1);

    if (sem.dinit_data) {
      int rank;

      /* build return type */
      stkp = ARG_STK(0);
      ad = AD_DPTR(SST_DTYPEG(stkp));
      rank = AD_NUMDIM(ad); /* rank of array arg, upper bound of result array */
      sem.arrdim.ndim = 1;
      sem.arrdim.ndefer = 0;
      sem.bounds[0].lowtype = S_CONST;
      sem.bounds[0].lowb = 1;
      sem.bounds[0].lwast = 0;
      sem.bounds[0].uptype = S_CONST;
      sem.bounds[0].upb = rank;
      sem.bounds[0].upast =
          mk_cval(rank, (!dtyper2) ? stb.user.dt_int : dtyper2);
      dtyper = mk_arrdsc();
      DTY(dtyper + 1) = (!dtyper2) ? stb.user.dt_int : dtyper2;

      gen_init_intrin_call(stktop, pdsym, count, dtyper, FALSE);
      return 0;
    }

    ad = AD_DPTR(dtyper);
    count = rank_of_ast(ARG_AST(0));
    AD_NUMELM(ad) = AD_UPBD(ad, 0) = AD_UPAST(ad, 0) =
        mk_isz_cval(count, astb.bnd.dtype);
    shape1 = A_SHAPEG(ARG_AST(0));
    argt_count = 3 * count + 2;
    tmp = get_arr_temp(dtyper, FALSE, FALSE, FALSE);
    arrtmp_ast = mk_id(tmp);
    shaper = A_SHAPEG(arrtmp_ast);
    sptr = find_pointer_variable(ARG_AST(0));
    if (sptr && (POINTERG(sptr) || (ALLOCG(sptr) && SDSCG(sptr)))) {
      hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(RTE_shapeDsc), DT_NONE);
      ast = begin_call(A_CALL, hpf_sym, 2);
      add_arg(arrtmp_ast);
      add_arg(check_member(ARG_AST(0), mk_id(SDSCG(sptr)))); /* rank */
    } else {
      switch (dtyper2) {
      case 0:
        rtlRtn = RTE_shape;
        break;
      case DT_BINT:
        rtlRtn = RTE_shape1;
        break;
      case DT_SINT:
        rtlRtn = RTE_shape2;
        break;
      case DT_INT4:
        rtlRtn = RTE_shape4;
        break;
      case DT_INT8:
        rtlRtn = RTE_shape;
        break;
      default:
        error(155, 3, gbl.lineno, SYMNAME(gbl.currsub),
              "invalid kind argument for shape");
      }
      hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), DT_NONE);
      ast = begin_call(A_CALL, hpf_sym, argt_count);
      add_arg(arrtmp_ast);
      add_arg(mk_isz_cval((INT)count, astb.bnd.dtype)); /* rank */
      for (i = 0; i < count; i++) {
        add_arg((int)SHD_LWB(shape1, i));
        add_arg((int)SHD_UPB(shape1, i));
        add_arg((int)SHD_STRIDE(shape1, i));
      }
    }
    (void)add_stmt(ast);
    ast = arrtmp_ast;
    goto expr_val;

  case PD_reshape:
    if (count < 2 || count > 4) {
      E74_CNT(pdsym, count, 2, 4);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 4, KWDARGSTR(pdsym)))
      goto exit_;

    stkp = ARG_STK(1); /* shape */
    dtype1 = SST_DTYPEG(stkp);
    if (!DT_ISINT_ARR(dtype1)) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }

    shape_acl = NULL;
    if (SST_IDG(stkp) == S_ACONST) {
      shape_acl = SST_ACLG(stkp);
    }

    if (shape_acl && shape_acl->is_const) {
      shape_acl = SST_ACLG(stkp);
      count = get_int_cval(sym_of_ast(AD_NUMELM(AD_DPTR(dtype1))));
      if (count < 0 || count > 7) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    } else
      shape_acl = NULL;

    stkp = ARG_STK(0);
    dtyper = SST_DTYPEG(stkp); /* source */
    if (DTY(dtyper) != TY_ARRAY) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    if (SST_IDG(stkp) == S_IDENT) {
      int allo_sptr = SST_SYMG(stkp);
      if (ALLOCATTRG(allo_sptr)) {
        ALLOCDESCP(allo_sptr, TRUE);
      }
    }
    argt_count = 4;

    stkp = ARG_STK(1); /* shape */

    (void)mkexpr(ARG_STK(1));
    XFR_ARGAST(1);
    if (shape_acl == NULL) {
      ast = ARG_AST(1);
      if (sem.dinit_data && !SST_SHAPEG(stkp)) {
        if (ADD_NUMDIM(A_DTYPEG(ast)) != 1) {
          E74_ARG(pdsym, 1, NULL);
          goto call_e74_arg;
        }
        tmp = ADD_NUMELM(A_DTYPEG(ast));
      } else {
        shape1 = SST_SHAPEG(stkp);
        if (shape1 == 0 || SHD_NDIM(shape1) != 1) {
          E74_ARG(pdsym, 1, NULL);
          goto call_e74_arg;
        }
        tmp = size_of_ast(ast);
      }

      if (A_TYPEG(tmp) != A_CNST) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
      count = get_int_cval(A_SPTRG(tmp));
      if (count < 0 || count > 7) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    }

    if ((stkp = ARG_STK(2))) { /* pad */
      (void)mkexpr(stkp);
      XFR_ARGAST(2);
      dtype2 = SST_DTYPEG(stkp);
      if (DTY(dtype2) != TY_ARRAY || DTY(dtype2 + 1) != DTY(dtyper + 1)) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
    }
    if ((stkp = ARG_STK(3))) { /* order */
      (void)mkexpr(stkp);
      XFR_ARGAST(3);
      dtype2 = SST_DTYPEG(stkp);
      if (!DT_ISINT(DTY(dtype2 + 1)) ||
          count != get_int_cval(sym_of_ast(AD_NUMELM(AD_DPTR(dtype2))))) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
    }

    sem.arrdim.ndim = 1;
    (void)mkexpr(ARG_STK(0));

    XFR_ARGAST(0);

    if (sem.dinit_data) {
      ACL *aclp = shape_acl;

      if (!DT_ISINT(DTY(SST_DTYPEG(ARG_STK(1)) + 1))) { /* shape */
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }

      if ((stkp = ARG_STK(2))) { /* pad */
        if (DTY(SST_DTYPEG(stkp) + 1) != DTY(dtyper + 1)) {
          sem.dinit_error = TRUE;
          E74_ARG(pdsym, 2, NULL);
          goto call_e74_arg;
        }
      }

      if ((stkp = ARG_STK(3))) { /* order */
        dtype2 = SST_DTYPEG(ARG_STK(3));
        if (!DT_ISINT(DTY(dtype2 + 1)) ||
            count != get_int_cval(sym_of_ast(AD_NUMELM(AD_DPTR(dtype2))))) {
          sem.dinit_error = TRUE;
          E74_ARG(pdsym, 3, NULL);
          goto call_e74_arg;
        }
      }

      if (!aclp) {
        aclp = construct_acl_from_ast(SST_ASTG(ARG_STK(1)), 0, 0);
      }
      aclp = eval_init_expr(aclp);

      add_shape_rank(count);
      sem.arrdim.ndim = count;
      sem.arrdim.ndefer = 0;
      aclp = (aclp->id == AC_ACONST ? aclp->subc : aclp);
      if (!aclp) {
        return 0;
      }
      for (i = 0; i < count; i++) {
        int ubast = mk_bnd_int(aclp->u1.ast);
        add_shape_spec(astb.bnd.one, ubast, astb.bnd.one);

        sem.bounds[i].lowtype = S_CONST;
        sem.bounds[i].lowb = 1;
        sem.bounds[i].lwast = 0;
        sem.bounds[i].uptype = S_CONST;
        sem.bounds[i].upb = get_int_cval(A_SPTRG(aclp->u1.ast));
        sem.bounds[i].upast = ubast;
        sem.bounds[i].upast = ubast;

        aclp = aclp->next;
      }
      shaper = mk_shape();
      dtyper = mk_arrdsc();
      DTY(dtyper + 1) = DDTG(SST_DTYPEG(ARG_STK(0)));

      gen_init_intrin_call(stktop, pdsym, argt_count, dtyper, FALSE);

      A_SHAPEP(SST_ASTG(stktop), shaper);

      return 0;
    }

    if (shape_acl != NULL) {
      add_shape_rank(count);
      shape_acl = shape_acl->subc; /* go down to element list */
      for (i = 0; i < count; i++) {
        add_shape_spec(astb.bnd.one, mk_bnd_int(shape_acl->u1.ast),
                       astb.bnd.one);
        shape_acl = shape_acl->next;
      }
      shaper = mk_shape();
    } else {
      /*
       * compute the shape for the result of 'reshape':
       * o   count is the size of the shape argument and represents the
       *     rank of the result.
       * o   for each dimension in the result, its upper bound is the
       *     value of the corresponding element in the shape argument.
       * o   to access an element of the shape argument, a subscripted
       *     reference of the shape argument must be generated; the
       *     subscript will consist of any non-triple subscripts; the
       *     triple subscript will be replaced with the 'current' index.
       * o   the shape descriptor is used to generate a sequence of
       *     indices; e.g.,   lwb : upb : stride.
       */
      int arr;
      int subs[7];
      int asd;
      int dim = 0;
      int nsubs = 1;
      int ix;
      int shp[7];
      int eldtype;

      eldtype = DDTG(A_DTYPEG(ast));
      arr = ast;
      if (A_TYPEG(ast) == A_SUBSCR) {
        arr = A_LOPG(ast);
        asd = A_ASDG(ast);
        nsubs = ASD_NDIM(asd);
        for (i = 0; i < nsubs; i++) {
          tmp = ASD_SUBS(asd, i);
          if (A_TYPEG(tmp) == A_TRIPLE)
            dim = i;
          else
            subs[i] = tmp;
        }
      }

      ix = SHD_LWB(shape1, 0);
      for (i = 0; i < count; i++) {
        int src;
        int asn;

        subs[dim] = ix;
        ix = mk_binop(OP_ADD, ix, (int)SHD_STRIDE(shape1, 0), astb.bnd.dtype);
        shp[i] = mk_id(get_temp(astb.bnd.dtype));
        src = mk_subscr(arr, subs, nsubs, eldtype);
        asn = mk_assn_stmt(shp[i], src, astb.bnd.dtype);
        (void)add_stmt(asn);
      }
      add_shape_rank(count);
      for (i = 0; i < count; i++)
        add_shape_spec(astb.bnd.one, shp[i], astb.bnd.one);
      shaper = mk_shape();
    }
    break;

  case PD_merge:
    if (count != 3) {
      E74_CNT(pdsym, count, 3, 3);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 3, KWDARGSTR(pdsym)))
      goto exit_;

    stkp = ARG_STK(2);
    if (!DT_ISLOG(DDTG(SST_DTYPEG(stkp)))) { /* mask */
      E74_ARG(pdsym, 2, NULL);
      goto call_e74_arg;
    }
    dtype2 = SST_DTYPEG(stkp);
    shape2 = SST_SHAPEG(stkp);

    stkp = ARG_STK(0); /* tsource */
    dtyper = SST_DTYPEG(stkp);
    shaper = SST_SHAPEG(stkp);

    stkp = ARG_STK(1); /* fsource */
    dtype1 = SST_DTYPEG(stkp);
    shape1 = SST_SHAPEG(stkp);
    if (DDTG(dtyper) != DDTG(dtype1)) {
      if (DTYG(dtyper) == TY_CHAR || DTYG(dtyper) == TY_NCHAR) {
        if (DTYG(dtyper) != DTYG(dtype1)) {
          E74_ARG(pdsym, 1, NULL);
          goto call_e74_arg;
        }
      } else {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    }
    shaper = set_shape_result(shaper, shape1);
    if (shaper < 0) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    sptr = (shaper == shape1 ? SST_SYMG(ARG_STK(1)) : SST_SYMG(ARG_STK(0)));

    shaper = set_shape_result(shaper, shape2);
    if (shaper < 0) {
      E74_ARG(pdsym, 2, NULL);
      goto call_e74_arg;
    }
    sptr = (shaper == shape2 ? SST_SYMG(ARG_STK(2)) : sptr);

    if (shaper && DTY(dtyper) != TY_ARRAY) {
      dtyper = get_array_dtype(SHD_NDIM(shaper), dtyper);
      ad = AD_DPTR(dtyper);
      for (i = 0; i < (int)SHD_NDIM(shaper); i++) {
        AD_LWBD(ad, i) = AD_LWAST(ad, i) = SHD_LWB(shaper, i);
        AD_UPBD(ad, i) = AD_UPAST(ad, i) = SHD_UPB(shaper, i);
        AD_EXTNTAST(ad, i) = mk_extent(AD_LWAST(ad, i), AD_UPAST(ad, i), i);
      }
    }

    ast = ARG_AST(2);
    hpf_sym = getMergeSym((int)DDTG(dtyper), IK_ELEMENTAL);
    switch (DTYG(dtyper)) {
    case TY_CHAR:
    case TY_NCHAR:
      dtype1 = DDTG(dtyper);
      if (dtype1 == DT_ASSCHAR || dtype1 == DT_DEFERCHAR) {
        tmp = ast_intr(I_LEN, DT_INT4, 1, ARG_AST(0));
        dtype1 = get_type(2, TY_CHAR, tmp);
        if (DTY(dtyper) != TY_ARRAY) {
          dtyper = dtype1;
        } else {
          dtyper = dup_array_dtype(dtyper);
          DTY(dtyper + 1) = dtype1;
        }
      } else if (dtype1 == DT_ASSNCHAR || dtype1 == DT_DEFERCHAR) {
        tmp = ast_intr(I_LEN, DT_INT4, 1, ARG_AST(0));
        dtype1 = get_type(2, TY_NCHAR, tmp);
        if (DTY(dtyper) != TY_ARRAY) {
          dtyper = dtype1;
        } else {
          dtyper = dup_array_dtype(dtyper);
          DTY(dtyper + 1) = dtype1;
        }
      }
      arrtmp_ast = mk_id(get_ch_temp(dtyper));
      func_ast = begin_call(A_ICALL, hpf_sym, 5);
      A_OPTYPEP(func_ast, INTASTG(pdsym));
      add_arg(arrtmp_ast);
      add_arg(ARG_AST(0));
      add_arg(ARG_AST(1));
      add_arg(ast);
      add_arg(mk_cval(size_of(DDTG(A_DTYPEG(ast))), DT_INT));
      (void)add_stmt(func_ast);
      ast = arrtmp_ast;
      break;
    case TY_DERIVED:
      if (shaper)
        arrtmp_ast = mk_id(get_arr_temp(dtyper, FALSE, FALSE, FALSE));
      else
        arrtmp_ast = mk_id(get_temp(dtyper));
      func_ast = begin_call(A_ICALL, hpf_sym, 6);
      A_OPTYPEP(func_ast, INTASTG(pdsym));
      add_arg(arrtmp_ast);
      add_arg(ARG_AST(0));
      add_arg(ARG_AST(1));
      add_arg(
          mk_cval(size_of(DDTG(dtyper)), DT_INT)); /* size of derived type */
      add_arg(ast);
      add_arg(mk_cval(size_of(DDTG(A_DTYPEG(ast))), DT_INT));
      (void)add_stmt(func_ast);
      ast = arrtmp_ast;
      break;
    default:
      argt = mk_argt(4); /* space for arguments */
      ARGT_ARG(argt, 0) = ARG_AST(0);
      ARGT_ARG(argt, 1) = ARG_AST(1);
      ARGT_ARG(argt, 2) = ast;
      ARGT_ARG(argt, 3) = mk_cval(size_of(DDTG(A_DTYPEG(ast))), DT_INT);
      func_ast = mk_id(hpf_sym);
      ast = mk_func_node(A_INTR, func_ast, 4, argt);
      A_DTYPEP(ast, dtyper);
      A_OPTYPEP(ast, INTASTG(pdsym));
      if (shaper == 0)
        shaper = mkshape(dtyper);
    }
    goto expr_val;

  case PD_dsize:
    if (!XBIT(49, 0x40)) /* if xbit set, CM fortran intrinsics allowed */
      goto bad_args;
  case PD_size:
    if (count == 0 || count > 3) {
      E74_CNT(pdsym, count, 1, 3);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 3, KWDARGSTR(pdsym)))
      goto exit_;

    (void)mkarg(ARG_STK(0), &dum);
    XFR_ARGAST(0);
    argt_count = 2;
    shaper = 0;
    if ((stkp = ARG_STK(2))) { /* KIND */
      dtyper = set_kind_result(stkp, DT_INT, TY_INT);
      if (!dtyper) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
    } else {
      if (XBIT(68, 0x1) && XBIT(68, 0x2))
        dtyper = DT_INT8;
      else
        dtyper = stb.user.dt_int;
    }

    if (sem.dinit_data) {
      gen_init_intrin_call(stktop, pdsym, count, dtyper, FALSE);
      return 0;
    }

    dtype1 = SST_DTYPEG(ARG_STK(0));
    if (DTY(dtype1) != TY_ARRAY) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    asumsz = 0;
    ast = ARG_AST(0);
    if (A_TYPEG(ast) == A_INTR) {
      switch (A_OPTYPEG(ast)) {
      case I_ADJUSTL: /* adjustl(string) */
      case I_ADJUSTR: /* adjustr(string) */
        /*  len is just len(string) */
        ast = ARGT_ARG(A_ARGSG(ast), 0);
        ARG_AST(0) = ast;
        break;
      }
    }
    switch (A_TYPEG(ast)) {
    case A_ID:
      asumsz = A_SPTRG(ast);
      if (SCG(asumsz) != SC_DUMMY || !ASUMSZG(asumsz))
        asumsz = 0;
      break;
    case A_MEM:
      /* elide any scalar members */
      while (TRUE) {
        sptr = A_SPTRG(A_MEMG(ast));
        if (DTY(DTYPEG(sptr)) == TY_ARRAY)
          break;
        ast = A_PARENTG(ast);
        if (A_TYPEG(ast) == A_ID)
          break;
        if (A_TYPEG(ast) == A_SUBSCR)
          break;
      }
      ARG_AST(0) = ast;
      break;
    default:
      break;
    }
    sptr = find_pointer_variable(ast);
    if (sptr && (POINTERG(sptr) || (ALLOCG(sptr) && SDSCG(sptr)))) {
      /* pghpf_size(dim, static_descriptor) */
      if ((stkp = ARG_STK(1))) { /* dim */
        (void)mkexpr(stkp);
        XFR_ARGAST(1);
        dtype2 = SST_DTYPEG(stkp);
        if (!DT_ISINT(dtype2)) {
          E74_ARG(pdsym, 1, NULL);
          goto call_e74_arg;
        }
        ARG_AST(1) = mk_bnd_int(ARG_AST(1));
      } else
        ARG_AST(1) = astb.ptr0;

      if (XBIT(68, 0x1))
        hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(RTE_sizeDsc), dtyper);
      else
        hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(RTE_sizeDsc), dtyper);
      ast = begin_call(A_FUNC, hpf_sym, 2);
      A_DTYPEP(ast, dtyper);
      add_arg(ARG_AST(1));
      add_arg(check_member(ARG_AST(0), mk_id(SDSCG(sptr)))); /* rank */
      goto expr_val;
    }
    shape1 = A_SHAPEG(ARG_AST(0));
    count = SHD_NDIM(shape1);  /* rank of array arg */
    if ((stkp = ARG_STK(1))) { /* dim */
      (void)mkexpr(stkp);
      XFR_ARGAST(1);
      dtype2 = SST_DTYPEG(stkp);
      if (!DT_ISINT(dtype2)) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
      if ((ast = A_ALIASG(ARG_AST(1)))) {
        /* dim is a constant */
        i = get_int_cval(A_SPTRG(ast));
        if (i < 1 || i > count) {
          error(423, 3, gbl.lineno, NULL, NULL);
          i = 1;
        }
        if (asumsz && i == count)
          error(84, 3, gbl.lineno, SYMNAME(asumsz),
                "- size of assumed size array is unknown");
        /*
         * Before computing the extent, ensure that an upper bound
         * for this dimension exists.  The upper bound may be zero
         * if the array is an argument declared in an interface
         * within a module.
         */
        if (SHD_UPB(shape1, i - 1)) {
          ast = extent_of_shape(shape1, i - 1);
          if (A_ALIASG(ast)) {
            ast = A_ALIASG(ast);
            iszval = get_isz_cval(A_SPTRG(ast));
            goto const_isz_val;
          } else {

            (void)sym_mkfunc_nodesc(mkRteRtnNm(RTE_size), stb.user.dt_int);

            goto gen_call;
          }
        }
        if (sem.interface) {
          /*
           * if this expression is rewritten (i.e., when this
           * function specified by this interface is invoked),
           * ast_rewrite() will select the size based on the
           * constant dim value.
           */

          (void)sym_mkfunc_nodesc(mkRteRtnNm(RTE_size), stb.user.dt_int);

          goto gen_call;
        }
        goto expr_val;
      }
    } else {
      if (asumsz)
        error(84, 3, gbl.lineno, SYMNAME(asumsz),
              "- size of assumed size array is unknown");
      else {
        for (i = 0; i < count; i++) {
          if (SHD_LWB(shape1, i) == 0 || A_ALIASG(SHD_LWB(shape1, i)) == 0 ||
              SHD_UPB(shape1, i) == 0 || A_ALIASG(SHD_UPB(shape1, i)) == 0 ||
              (SHD_STRIDE(shape1, i) != 0 &&
               A_ALIASG(SHD_STRIDE(shape1, i)) == 0)) {
            goto PD_size_nonconstant;
          }
        }
        ast = extent_of_shape(shape1, 0);
        for (i = 1; i < count; i++) {
          int e;
          e = extent_of_shape(shape1, i);
          if (A_ALIASG(e)) { /* should be constant, but ... */
            if (get_isz_cval(A_SPTRG(e)) <= 0) {
              ast = astb.bnd.zero;
              break;
            }
          } else
            goto PD_size_nonconstant;
          ast = mk_binop(OP_MUL, ast, e, astb.bnd.dtype);
        }
        if (A_ALIASG(ast)) { /* should be constant, but ... */
          ast = A_ALIASG(ast);
          iszval = get_isz_cval(A_SPTRG(ast));
          goto const_isz_val;
        }
      }
    PD_size_nonconstant:
      ARG_AST(1) = astb.ptr0;
    }

    (void)sym_mkfunc_nodesc(mkRteRtnNm(RTE_size), dtyper);
    break;

  case PD_allocated:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    argt_count = 1;
    ast = SST_ASTG(ARG_STK(0));
    if (A_TYPEG(ast) != A_ID && A_TYPEG(ast) != A_MEM) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    i = memsym_of_ast(ast);
    dtype1 = DTYPEG(i);
    if (!ALLOCG(i) || TPALLOCG(i)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    ad = AD_DPTR(dtype1);
    if (DTY(dtype1) == TY_ARRAY) {
      ad = AD_DPTR(dtype1);
      if (AD_DEFER(ad) == 0) {
        E74_CNT(pdsym, count, 1, 1);
        goto call_e74_cnt;
      }
    }
    dtyper = stb.user.dt_log;

    break;

  case PD_present:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    dont_issue_assumedsize_error = 1;
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    dont_issue_assumedsize_error = 0;
    argt_count = 1;
    ast = SST_ASTG(ARG_STK(0));
    if (A_TYPEG(ast) != A_ID) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    i = A_SPTRG(ast);
    if (gbl.internal > 1 && !INTERNALG(i) && NEWARGG(i)) {
      i = NEWARGG(i);
      ARG_AST(0) = mk_id(i);
    } else if (SCG(i) != SC_DUMMY) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if (!OPTARGG(i))
      error(84, 3, gbl.lineno, SYMNAME(i), "- must be an OPTIONAL argument");
    dtyper = stb.user.dt_log;

    if (DTYG(DTYPEG(i)) == TY_CHAR || DTYG(DTYPEG(i)) == TY_NCHAR)
      (void)sym_mkfunc_nodesc(mkRteRtnNm(RTE_presentc), stb.user.dt_log);
    else if (!XBIT(57, 0x80000) && POINTERG(i))
      (void)sym_mkfunc_nodesc(mkRteRtnNm(RTE_present_ptr), stb.user.dt_log);
    else
      (void)sym_mkfunc_nodesc(mkRteRtnNm(RTE_present), stb.user.dt_log);
    break;

  case PD_kind:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    dtype1 = DDTG(SST_DTYPEG(ARG_STK(0)));
    conval = kind_of(dtype1);
    if (conval <= 0) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    goto const_default_int_val; /*return default integer*/

  case PD_selected_int_kind:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    dtype1 = SST_DTYPEG(stkp);
    if (!DT_ISINT(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    if (sem.dinit_data) {
      gen_init_intrin_call(stktop, pdsym, count, stb.user.dt_int, FALSE);
      return 0;
    }

    ast = SST_ASTG(stkp);
    if (A_ALIASG(ast)) {
      ast = A_ALIASG(ast);
      con1 = A_SPTRG(ast);
      con1 = CONVAL2G(con1);
      conval = 4;
      if (con1 > 18 || (con1 > 9 && XBIT(57, 2)))
        conval = -1;
      else if (con1 > 9)
        conval = 8;
      else if (con1 > 4)
        conval = 4;
      else if (con1 > 2)
        conval = 2;
      else
        conval = 1;
      goto const_default_int_val; /*return default integer*/
    }
    /* nonconstant argument, call RTE_sel_int_kind(r,descr) */
    XFR_ARGAST(0);
    func_type = A_FUNC;

    hpf_sym = sym_mkfunc(mkRteRtnNm(RTE_sel_int_kind), stb.user.dt_int);

    dtyper = stb.user.dt_int;
    break;

  case PD_selected_real_kind:
#ifdef PD_ieee_selected_real_kind
  case PD_ieee_selected_real_kind:
#endif
    if (count > 2 || count == 0) {
      E74_CNT(pdsym, count, 0, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;

    if (sem.dinit_data) {
      gen_init_intrin_call(stktop, pdsym, 2, stb.user.dt_int, FALSE);
      return 0;
    }

    stkp = ARG_STK(0);
    is_constant = TRUE;
    conval = 4;
    if (!stkp) {
      ARG_AST(0) = astb.ptr0;
    } else {
      dtype1 = SST_DTYPEG(stkp);
      if (!DT_ISINT(dtype1)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
      XFR_ARGAST(0);
      ast = SST_ASTG(stkp);
      if (!A_ALIASG(ast)) {
        is_constant = FALSE;
      } else {
        ast = A_ALIASG(ast);
        con1 = A_SPTRG(ast);
        con1 = CONVAL2G(con1);
        if (con1 <= 6)
          conval = 4;
        else if (con1 <= 15)
          conval = 8;
        else if (con1 <= 31 && !XBIT(57, 4))
          conval = 16;
        else
          conval = -1;
      }
    }
    stkp = ARG_STK(1);
    if (!stkp) {
      ARG_AST(1) = astb.ptr0;
    } else {
      dtype1 = SST_DTYPEG(stkp);
      if (!DT_ISINT(dtype1)) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
      XFR_ARGAST(1);
      ast = SST_ASTG(stkp);
      if (!A_ALIASG(ast)) {
        is_constant = FALSE;
      } else {
        ast = A_ALIASG(ast);
        con1 = A_SPTRG(ast);
        con1 = CONVAL2G(con1);
        if (XBIT(49, 0x40000)) {
          /* Cray C90 */
          if (con1 <= 37) {
            if (conval > 0 && conval < 4)
              conval = 4;
          } else if (con1 <= 2465) {
            if (conval > 0 && conval < 8)
              conval = 8;
          } else {
            if (conval > 0)
              conval = 0;
            conval -= 2;
          }
        } else {
          /* ANSI */
          if (con1 <= 37) {
            if (conval > 0 && conval < 4)
              conval = 4;
          } else if (con1 <= 307) {
            if (conval > 0 && conval < 8)
              conval = 8;
          } else if (con1 <= 4931 && !XBIT(57, 4)) {
            if (conval > 0 && conval < 16)
              conval = 16;
          } else {
            if (conval > 0)
              conval = 0;
            conval -= 2;
          }
        }
      }
    }
    if (is_constant) {
      goto const_default_int_val; /*return default integer*/
    }
    /* nonconstant argument, call RTE_sel_int_kind(r,descr) */
    func_type = A_FUNC;

    hpf_sym = sym_mkfunc(mkRteRtnNm(RTE_sel_real_kind), stb.user.dt_int);
    dtyper = stb.user.dt_int;
    argt_count = 2;
    break;

  case PD_selected_char_kind:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    dtype1 = SST_DTYPEG(stkp);
    if (DTY(dtype1) != TY_CHAR) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if (sem.dinit_data) {
      gen_init_intrin_call(stktop, pdsym, count, stb.user.dt_int, FALSE);
      return 0;
    }
    ast = SST_ASTG(stkp);
    if (A_ALIASG(ast)) {
      ast = A_ALIASG(ast);
      con1 = A_SPTRG(ast);
      conval = _selected_char_kind(con1);
      goto const_default_int_val; /*return default integer*/
    }
    /* nonconstant argument, call RTE_sel_char_kind(r,descr) */
    XFR_ARGAST(0);
    func_type = A_FUNC;

    hpf_sym = sym_mkfunc(mkRteRtnNm(RTE_sel_char_kinda), stb.user.dt_int);

    dtyper = stb.user.dt_int;
    break;

  case PD_new_line:
    if (count == 0 || count > 1) {
      E74_CNT(pdsym, count, 0, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    dtype1 = DDTG(SST_DTYPEG(stkp));
    if (DTY(dtype1) != TY_CHAR && DTY(dtype1) != TY_NCHAR) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    dtyper = dtype1;
    ch = 10;
    conval = getstring(&ch, 1);
    goto const_return;
    break;
  case PD_is_iostat_end:
  case PD_is_iostat_eor:
    if (count < 1 || count > 1) {
      E74_CNT(pdsym, count, 0, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    dtype1 = SST_DTYPEG(stkp);
    if (!DT_ISINT(DDTG(dtype1))) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    ast = ARG_AST(0);
    shaper = SST_SHAPEG(stkp);
    dtyper = stb.user.dt_log; /* default logical */
    if (shaper)
      dtyper = get_array_dtype(1, dtyper);

    if (pdtype == PD_is_iostat_end) {
      hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(RTE_is_iostat_end), dtyper);
    } else {
      hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(RTE_is_iostat_eor), dtyper);
    }
    ELEMENTALP(hpf_sym, 1);
    EXTSYMP(pdsym, hpf_sym);
    DTYPEP(hpf_sym, dtyper);

    argt_count = 1;
    ast = mk_convert(ast, DT_INT4);
    ast = mk_unop(OP_VAL, ast, DT_INT4);
    argt = mk_argt(1);
    ARGT_ARG(argt, 0) = ast;
    func_ast = mk_id(hpf_sym);
    A_DTYPEP(func_ast, dtyper);
    func_type = A_FUNC;
    ast = mk_func_node(func_type, func_ast, 1, argt);
    if (shaper)
      dtyper = dtype_with_shape(dtyper, shaper);
    A_DTYPEP(ast, dtyper);
    if (shaper == 0)
      shaper = mkshape(dtyper);

    goto expr_val;

    break;
  case PD_achar:
    if (count < 1 || count > 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    /* TBD - array argument */
    stkp = ARG_STK(0);
    dtype1 = SST_DTYPEG(stkp);
    if (!DT_ISINT(DDTG(dtype1))) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    shaper = SST_SHAPEG(stkp);
    ast = ARG_AST(0);
    dtyper = DT_CHAR; /* default kind */
    if ((stkp = ARG_STK(1))) {
      dtyper = set_kind_result(stkp, DT_CHAR, TY_CHAR);
      if (!dtyper) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    }

    if (shaper) {
      dtyper = get_array_dtype(SHD_NDIM(shaper), dtyper);
      ad = AD_DPTR(dtyper);
      for (i = 0; i < (int)SHD_NDIM(shaper); i++) {
        AD_LWBD(ad, i) = AD_LWAST(ad, i) = SHD_LWB(shaper, i);
        AD_UPBD(ad, i) = AD_UPAST(ad, i) = SHD_UPB(shaper, i);
        AD_EXTNTAST(ad, i) = mk_extent(AD_LWAST(ad, i), AD_UPAST(ad, i), i);
      }
    } else if (A_ALIASG(ast)) {
      ch = get_int_cval(A_SPTRG(A_ALIASG(ast)));
      conval = getstring(&ch, 1);
      goto const_return;
    }
    if (DTY(dtyper) == TY_NCHAR) {
      sptr = intast_sym[I_NCHAR];
      ast = begin_call(A_INTR, sptr, 1);
      add_arg(ARG_AST(0));
      A_DTYPEP(ast, dtyper);
      A_OPTYPEP(ast, I_NCHAR);
    } else
    {
      sptr = intast_sym[I_ACHAR];
      ast = begin_call(A_INTR, sptr, 1);
      add_arg(ARG_AST(0));
      A_DTYPEP(ast, dtyper);
      A_OPTYPEP(ast, I_ACHAR);
    }
    goto expr_val;

  case PD_adjustl:
  case PD_adjustr:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    dtype1 = SST_DTYPEG(stkp);
    dtyper = dtype1;
    shaper = SST_SHAPEG(stkp);
    if (DTYG(dtype1) != TY_CHAR && DTYG(dtype1) != TY_NCHAR) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    ast = ARG_AST(0);
    if (A_ALIASG(ast)) {
      if (pdtype == PD_adjustl)
        sptr = _adjustl(A_SPTRG(A_ALIASG(ast)));
      else
        sptr = _adjustr(A_SPTRG(A_ALIASG(ast)));
      goto const_str_val;
    }

    if (sem.dinit_data) {
      gen_init_intrin_call(stktop, pdsym, count, DDTG(dtype1), TRUE);
      return 0;
    }

    /* check if the dtype warrants an allocatable temp; if so,
     * need indicate this so that if the context is a relational
     * expression, the expression will be evaluated an assigned
     * to a temp.
     */
    (void)need_alloc_ch_temp(dtyper);
    break;

  case PD_bit_size:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    dtyper = DDTG(SST_DTYPEG(ARG_STK(0)));
    switch (DTY(dtyper)) {
    case TY_BINT:
    case TY_SINT:
    case TY_INT:
    case TY_INT8:
      conval = bits_in(dtyper);
      break;
    default:
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    goto const_kind_int_val;

  case PD_digits:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    dtype1 = DDTG(SST_DTYPEG(ARG_STK(0)));
    switch (DTY(dtype1)) {
    case TY_BINT:
      conval = 7;
      break;
    case TY_SINT:
      conval = 15;
      break;
    case TY_INT:
      conval = 31;
      break;
    case TY_INT8:
      conval = 63;
      break;
    /* values for real/double taken from float.h <type>_MANT_DIG */
    case TY_REAL:
      conval = 24;
      break;
    case TY_DBLE:
      if (XBIT(49, 0x40000)) /* C90 */
        conval = 47;
      else
        conval = 53;
      break;
    case TY_QUAD:
      if (XBIT(49, 0x40000)) /* C90 */
        conval = 95;
      else
        conval = 113;
      break;
    default:
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    goto const_default_int_val; /*return default integer*/

  case PD_epsilon:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    dtype1 = DDTG(SST_DTYPEG(ARG_STK(0)));
    switch (DTY(dtype1)) {
    case TY_REAL:
      val[0] = 0x34000000;
      sname = "epsilon(1.0_4)";
      goto const_real_val;
    case TY_DBLE:
      if (XBIT(49, 0x40000)) { /* C90 */
#define C90_EPSILON "0.1421085471520200e-13"
        atoxd(C90_EPSILON, &val[0], strlen(C90_EPSILON));
      } else {
        val[0] = 0x3cb00000;
        val[1] = 0;
      }
      sname = "epsilon(1.0_8)";
      goto const_dble_val;
    default:
      break;
    }
    E74_ARG(pdsym, 0, NULL);
    goto call_e74_arg;

  case PD_exponent:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    dtype1 = DDTG(SST_DTYPEG(stkp));
    if (!DT_ISREAL(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if (DTY(dtype1) == TY_REAL)
      rtlRtn = RTE_expon;
    else /* TY_DBLE */
      rtlRtn = RTE_expond;

    fsptr = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), stb.user.dt_int);
    ELEMENTALP(fsptr, 1);
    shaper = SST_SHAPEG(stkp);
    if (shaper == 0)
      dtyper = stb.user.dt_int;
    else
      dtyper = aux.dt_iarray;
    break;

  case PD_fraction:
  case PD_rrspacing:
  case PD_spacing:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    dtyper = SST_DTYPEG(stkp);
    shaper = SST_SHAPEG(stkp);
    dtype1 = DDTG(dtyper);
    if (!DT_ISREAL(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if (DTY(dtype1) == TY_REAL) {
      switch (pdtype) {
      case PD_fraction:
        rtlRtn = RTE_frac;
        break;
      case PD_rrspacing:
        rtlRtn = RTE_rrspacing;
        break;
      case PD_spacing:
        rtlRtn = RTE_spacing;
        break;
      default:
        interr("PD_spacing, pdtype", pdtype, 3);
      }
    } else { /* TY_DBLE */
      switch (pdtype) {
      case PD_fraction:
        rtlRtn = RTE_fracd;
        break;
      case PD_rrspacing:
        rtlRtn = RTE_rrspacingd;
        break;
      case PD_spacing:
        rtlRtn = RTE_spacingd;
        break;
      default:
        interr("PD_spacingd, pdtype", pdtype, 3);
      }
    }
    (void)sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtype1);
    break;

  case PD_erf:
  case PD_erfc:
  case PD_erfc_scaled:
  case PD_gamma:
  case PD_log_gamma:
  case PD_acosh:
  case PD_asinh:
  case PD_atanh:
  case PD_bessel_j0:
  case PD_bessel_j1:
  case PD_bessel_y0:
  case PD_bessel_y1:
    /* TODO: where are the names for these set? */
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    dtyper = SST_DTYPEG(stkp);
    shaper = SST_SHAPEG(stkp);
    dtype1 = DDTG(dtyper);
    if (!DT_ISREAL(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    break;
  case PD_bessel_jn:
  case PD_bessel_yn:
    if (count < 2 || count > 3) {
      E74_CNT(pdsym, count, 2, 3);
      goto call_e74_cnt;
    }
    if (count == 2) {
      if (evl_kwd_args(list, 2, "n x"))
        goto exit_;

      dtype1 = DDTG(SST_DTYPEG(ARG_STK(0)));
      dtype2 = DDTG(SST_DTYPEG(ARG_STK(1)));
      if (!DT_ISINT(dtype1) || !DT_ISREAL(dtype2)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
      shaper = A_SHAPEG(ARG_AST(1));
      if (shaper < 0) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
      if (shaper) {
        dtyper = get_array_dtype(SHD_NDIM(shaper), dtype2);
      } else {
        dtyper = dtype2;
      }

      if (DTY(dtype1) != TY_INT) {
        ast = ARG_AST(0);
        ast = mk_convert(ast, dtype1);
        ARG_AST(0) = ast;
      }
    } else if (count == 3) {
      if (evl_kwd_args(list, 3, KWDARGSTR(pdsym)))
        goto exit_;

      if (!DT_ISINT(DDTG(SST_DTYPEG(ARG_STK(0)))) ||
          !DT_ISINT(DDTG(SST_DTYPEG(ARG_STK(1)))) ||
          !DT_ISREAL(DDTG(SST_DTYPEG(ARG_STK(2))))) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }

      dtype2 = DDTG(SST_DTYPEG(ARG_STK(2)));

      argt = mk_argt(4);

      sem.arrdim.ndim = 1;
      sem.arrdim.ndefer = 0;
      sem.bounds[0].lowtype = S_CONST;
      sem.bounds[0].lowb = 1;
      sem.bounds[0].lwast = 0;
      sem.bounds[0].uptype = S_EXPR;
      sem.bounds[0].upb = 0;
      sem.bounds[0].upast =
          mk_binop(OP_ADD, mk_binop(OP_SUB, ARG_AST(1), ARG_AST(0), DT_INT),
                   astb.bnd.one, DT_INT);
      dtyper = mk_arrdsc();
      DTY(dtyper + 1) = dtype2;

      shaper = mkshape(dtyper);
      arrtmp_ast = mk_id(get_arr_temp(dtyper, FALSE, FALSE, FALSE));
      ARGT_ARG(argt, 0) = arrtmp_ast;

      dtype1 = DDTG(SST_DTYPEG(ARG_STK(0)));
      ARGT_ARG(argt, 1) = SST_ASTG(ARG_STK(0));
      if (DTY(dtype1) != TY_INT) {
        ast = ARG_AST(0);
        ast = mk_convert(ast, dtype1);
        ARGT_ARG(argt, 1) = ast;
      }
      dtype1 = DDTG(SST_DTYPEG(ARG_STK(1)));
      ARGT_ARG(argt, 2) = SST_ASTG(ARG_STK(1));
      if (DTY(dtype1) != TY_INT) {
        ast = ARG_AST(1);
        ast = mk_convert(ast, dtype1);
        ARGT_ARG(argt, 2) = ast;
      }

      ARGT_ARG(argt, 3) = SST_ASTG(ARG_STK(2));

      if (DTY(dtype2) == TY_REAL) {
        switch (pdtype) {
        case PD_bessel_jn:
          name = "f90_bessel_jn";
          break;
        case PD_bessel_yn:
          name = "f90_bessel_yn";
          break;
        }
      } else { /* TY_DBLE */
        switch (pdtype) {
        case PD_bessel_jn:
          name = "f90_dbessel_jn";
          break;
        case PD_bessel_yn:
          name = "f90_dbessel_yn";
          break;
        }
      }

      hpf_sym = sym_mkfunc_nodesc(name, dtyper);
      func_ast = mk_id(hpf_sym);
      A_DTYPEP(func_ast, dtyper);
      ast = mk_func_node(A_CALL, func_ast, 4, argt);
      add_stmt(ast);
      dtyper = dtype1;
      A_DTYPEP(ast, dtyper);
      A_DTYPEP(func_ast, dtyper);
      A_SHAPEP(ast, shaper);

      SST_ASTP(stktop, arrtmp_ast);
      SST_SHAPEP(stktop, shaper);
      SST_DTYPEP(stktop, dtyper);
      SST_IDP(stktop, S_EXPR);

      EXPSTP(hpf_sym, 1);
      return 1;
    }
    break;
  case PD_hypot:
    if (count != 2) {
      E74_CNT(pdsym, count, 2, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    dtype1 = DDTG(SST_DTYPEG(ARG_STK(0)));
    dtype2 = DDTG(SST_DTYPEG(ARG_STK(1)));
    if (!DT_ISREAL(dtype1) || !DT_ISREAL(dtype2)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    shaper = SST_SHAPEG(ARG_STK(0));
    shape2 = SST_SHAPEG(ARG_STK(1));
    shaper = set_shape_result(shaper, shape2);
    if (shaper < 0) {
      E74_ARG(pdsym, 2, NULL);
      goto call_e74_arg;
    }
    if (shaper) {
      dtyper = get_array_dtype(SHD_NDIM(shaper), dtype1);
    } else {
      dtyper = dtype1;
    }
    if (DTY(dtype1) == TY_REAL) {
      rtlRtn = RTE_hypot;
    } else { /* TY_DBLE */
      rtlRtn = RTE_hypotd;
    }
    /* TODO: where is the call generated */
    break;

  case PD_huge:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    dtype1 = DDTG(SST_DTYPEG(ARG_STK(0)));
    ast = ast_intr(I_HUGE, dtype1, 0); /* returns a constant ast */
    switch (DTY(dtype1)) {
    case TY_BINT:
    case TY_SINT:
    case TY_INT:
      goto const_int_ast;
    case TY_INT8:
      goto const_int8_ast;
    case TY_REAL:
      goto const_real_ast;
    case TY_DBLE:
      goto const_dble_ast;
    case TY_QUAD:
      goto const_quad_ast;
    default:
      break;
    }
    E74_ARG(pdsym, 0, NULL);
    goto call_e74_arg;

  case PD_iachar:
    if (count == 0 || count > 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    dtype1 = SST_DTYPEG(stkp);
    if (DTYG(dtype1) != TY_CHAR && DTYG(dtype1) != TY_NCHAR) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    shaper = SST_SHAPEG(stkp);
    if ((stkp = ARG_STK(1))) { /* KIND */
      dtyper = set_kind_result(stkp, DT_INT, TY_INT);
      if (!dtyper) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    } else {
      dtyper = stb.user.dt_int;
    }
    if (sem.dinit_data) {
      gen_init_intrin_call(stktop, pdsym, count, dtyper, TRUE);
      return 0;
    }
    if (shaper) {
      dtyper = get_array_dtype(SHD_NDIM(shaper), dtyper);
      ad = AD_DPTR(dtyper);
      for (i = 0; i < (int)SHD_NDIM(shaper); i++) {
        AD_LWBD(ad, i) = AD_LWAST(ad, i) = SHD_LWB(shaper, i);
        AD_UPBD(ad, i) = AD_UPAST(ad, i) = SHD_UPB(shaper, i);
        AD_EXTNTAST(ad, i) = mk_extent(AD_LWAST(ad, i), AD_UPAST(ad, i), i);
      }
    } else if (A_ALIASG(ARG_AST(0))) { /* constant character */
      conval = stb.n_base[CONVAL1G(A_SPTRG(A_ALIASG(ARG_AST(0))))] & 0xff;
      conval = cngcon(conval, DT_INT4, dtyper);
      goto const_return;
    }

    break;

  case PD_ceiling:
  case PD_floor:
    if (count < 1 || count > 2) {
        E74_CNT(pdsym, count, 0, 2);
        goto call_e74_cnt;
    }
    if (get_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;

    stkp = ARG_STK(0);
    dtype1 = DDTG(SST_DTYPEG(stkp));
    if (!DT_ISREAL(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    dtyper = dtype1; /* initial result of call is type of argument */

    /* for this case dtype2 is used for conversion; the actual floor/ceiling
     * calls we use return real, but the Fortran declaration returns int.
     * We need to calculate final type for conversion to correct int kind.
     */

    if ((stkp = ARG_STK(1))) { /* kind */
      dtype2 = set_kind_result(stkp, DT_INT, TY_INT);
      if (!dtype2) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    } else {
      dtype2 = stb.user.dt_int;  /* default return type for floor/ceiling */
    }

    if (sem.dinit_data) {
      gen_init_intrin_call(stktop, pdsym, count, dtype2, TRUE);
      return 0;
    }

    /* If this is f90, leave the kind argument in. Otherwise issue
     * a warning and leave it -- we'll get to it someday
     */
    (void)mkexpr(ARG_STK(0));
    shaper = SST_SHAPEG(ARG_STK(0));
    XFR_ARGAST(0);
    argt_count = 1;
    if (ARG_STK(1)) {
      (void)mkexpr(ARG_STK(1));
      argt_count = 2;
      ARG_AST(1) = mk_cval1(target_kind(dtyper), DT_INT4);
    }
    if (shaper)
      dtyper = get_array_dtype(1, dtyper);
    goto gen_call;

  case PD_aint:
  case PD_anint:
    if (count < 1 || count > 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    if (SST_ISNONDECC(stkp))
      cngtyp(stkp, DT_INT);
    dtype1 = DDTG(SST_DTYPEG(stkp));
    if (!DT_ISREAL(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if ((stkp = ARG_STK(1))) { /* kind */
      dtyper = set_kind_result(stkp, DT_REAL, TY_REAL);
      if (!dtyper) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    } else
      dtyper = dtype1; /* result is type of argument */
    /* If this is f90, leave the kind argument in. Otherwise issue
     * a warning and leave it -- we'll get to it someday
     */
    (void)mkexpr(ARG_STK(0));
    shaper = SST_SHAPEG(ARG_STK(0));
    XFR_ARGAST(0);
    argt_count = 1;
    if (ARG_STK(1)) {
      (void)mkexpr(ARG_STK(1));
      argt_count = 2;
      ARG_AST(1) = mk_cval1(target_kind(dtyper), DT_INT4);
    }
    if (shaper)
      dtyper = get_array_dtype(1, dtyper);
    goto gen_call;

  case PD_int:
    if (count < 1 || count > 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;

    stkp = ARG_STK(0);
    stkp1 = ARG_STK(1);

    if (stkp1) { /* kind */
      dtyper = set_kind_result(stkp1, DT_INT, TY_INT);
      if (!dtyper) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    } else {
      dtyper = stb.user.dt_int; /* default integer*/
    }

    if (SST_ISNONDECC(stkp) || SST_DTYPEG(stkp) == DT_DWORD)
      cngtyp(stkp, dtyper);
    dtype1 = DDTG(SST_DTYPEG(stkp));
    if (!DT_ISNUMERIC(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    /* If this is f90, leave the kind argument in. Otherwise issue
     * a warning and leave it -- we'll get to it someday
     */
    if (is_sst_const(stkp)) {
      con1 = get_sst_cval(stkp);
      conval = cngcon(con1, dtype1, dtyper);
      goto const_return;
    }

    if (sem.dinit_data) {
      gen_init_intrin_call(stktop, pdsym, count, dtyper, TRUE);
      return 0;
    }

    (void)mkexpr(stkp);
    shaper = SST_SHAPEG(stkp);
    XFR_ARGAST(0);
    argt_count = 1;
    if (stkp1) {
      (void)mkexpr(stkp1);
      argt_count = 2;
      ARG_AST(1) = mk_cval1(target_kind(dtyper), DT_INT4);
    }
    if (dtyper == dtype1) {
      ast = ARG_AST(0);
      if (shaper)
        dtyper = get_array_dtype(1, dtyper);
      goto expr_val;
    }
    if (shaper)
      dtyper = get_array_dtype(1, dtyper);
    goto gen_call;

  case PD_nint:
    if (count < 1 || count > 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    if (SST_ISNONDECC(stkp))
      cngtyp(stkp, DT_INT);
    dtype1 = DDTG(SST_DTYPEG(stkp));
    if (!DT_ISREAL(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    dtyper = stb.user.dt_int;  /* default int */
    if ((stkp = ARG_STK(1))) { /* kind */
      dtyper = set_kind_result(stkp, DT_INT, TY_INT);
      if (!dtyper) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    }

    if (sem.dinit_data) {
      gen_init_intrin_call(stktop, pdsym, count, dtyper, TRUE);
      return 0;
    }

    /* If this is f90, leave the kind argument in. Otherwise issue
     * a warning and leave it -- we'll get to it someday
     */
    stkp = ARG_STK(0);
    if (is_sst_const(stkp)) {
      con1 = get_sst_cval(stkp);
      switch (DTY(dtype1)) {
      case TY_REAL:
        num1[0] = CONVAL2G(stb.flt0);
        if (xfcmp(con1, num1[0]) >= 0) {
          INT fv2_23 = 0x4b000000;
          if (xfcmp(con1, fv2_23) >= 0)
            xfadd(con1, CONVAL2G(stb.flt0), &res[0]);
          else
            xfadd(con1, CONVAL2G(stb.flthalf), &res[0]);
        } else {
          INT fvm2_23 = 0xcb000000;
          if (xfcmp(con1, fvm2_23) <= 0)
            xfsub(con1, CONVAL2G(stb.flt0), &res[0]);
          else
            xfsub(con1, CONVAL2G(stb.flthalf), &res[0]);
        }
        break;
      case TY_DBLE:
        if (const_fold(OP_CMP, con1, stb.dbl0, DT_REAL8) >= 0) {
          INT dv2_52[2] = {0x43300000, 0x00000000};
          INT d2_52;
          d2_52 = getcon(dv2_52, DT_DBLE);
          if (const_fold(OP_CMP, con1, d2_52, DT_REAL8) >= 0)
            res[0] = const_fold(OP_ADD, con1, stb.dbl0, DT_REAL8);
          else
            res[0] = const_fold(OP_ADD, con1, stb.dblhalf, DT_REAL8);
        } else {
          INT dvm2_52[2] = {0xc3300000, 0x00000000};
          INT dm2_52;
          dm2_52 = getcon(dvm2_52, DT_DBLE);
          if (const_fold(OP_CMP, con1, dm2_52, DT_REAL8) >= 0)
            res[0] = const_fold(OP_SUB, con1, stb.dblhalf, DT_REAL8);
          else
            res[0] = const_fold(OP_SUB, con1, stb.dbl0, DT_REAL8);
        }
        break;
      }
      conval = cngcon(res[0], dtype1, dtyper);
      goto const_return;
    }
    (void)mkexpr(ARG_STK(0));
    shaper = SST_SHAPEG(ARG_STK(0));
    XFR_ARGAST(0);
    argt_count = 1;
    if (ARG_STK(1)) {
      (void)mkexpr(ARG_STK(1));
      argt_count = 2;
      ARG_AST(1) = mk_cval1(target_kind(dtyper), DT_INT4);
    }
    if (shaper)
      dtyper = get_array_dtype(1, dtyper);
    goto gen_call;

  case PD_cmplx:
    if (count < 1 || count > 3) {
      E74_CNT(pdsym, count, 1, 3);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 3, KWDARGSTR(pdsym)))
      goto exit_;

    stkp = ARG_STK(0);
    stkp1 = ARG_STK(1);
    stkp2 = ARG_STK(2);

    if (stkp2) { /* kind */
      dtyper = set_kind_result(stkp2, DT_CMPLX, TY_CMPLX);
      dtype1 = dtyper == DT_CMPLX16 ? DT_REAL8 : DT_REAL4;
      if (!dtyper) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    } else {
      dtyper = stb.user.dt_cmplx; /* default complex */
      dtype1 = stb.user.dt_real;  /* default real    */
    }

    /* f2003 says that a boz literal can appear as an argument to
     * the real, dble, cmplx, and dcmplx intrinsics and its value
     * is used as the respective internal respresentation
     */
    if (SST_ISNONDECC(stkp) || SST_DTYPEG(stkp) == DT_DWORD)
      cngtyp(stkp, dtype1);
    if (stkp1 && (SST_ISNONDECC(stkp1) || SST_DTYPEG(stkp1) == DT_DWORD))
      cngtyp(stkp1, dtype1);

    dtype1 = DDTG(SST_DTYPEG(stkp));
    if (!DT_ISNUMERIC(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    /* If this is f90, leave the kind argument in. Otherwise issue
     * a warning and leave it -- we'll get to it someday
     */
    if (is_sst_const(stkp) && (!stkp1 || is_sst_const(stkp1))) {
      con1 = get_sst_cval(stkp);
      con1 = cngcon(con1, dtype1, dtyper);
      if (stkp1) {
        con2 = get_sst_cval(stkp1);
        con2 = cngcon(con2, DDTG(SST_DTYPEG(stkp1)), dtyper);
        num1[0] = CONVAL1G(con1);
        num1[1] = CONVAL1G(con2);
        conval = getcon(num1, dtyper);
      } else
        conval = con1;
      goto const_return;
    }
    (void)mkexpr(stkp);
    shaper = SST_SHAPEG(stkp);
    XFR_ARGAST(0);
    if (stkp1) {
      (void)mkexpr(stkp1);
      if (shaper == 0 && SST_SHAPEG(stkp1))
        shaper = SST_SHAPEG(stkp1);
      XFR_ARGAST(1);
    } else {
      ARG_AST(1) = 0;
    }
    argt_count = 3;
    ARG_AST(2) = 0;
    if (stkp2) { /* kind is present */
      (void)mkexpr(stkp2);
      ARG_AST(2) = mk_cval1(target_kind(dtyper), DT_INT4);
    }
    if (shaper)
      dtyper = get_array_dtype(1, dtyper);
    goto gen_call;

  case PD_real:
    if (count < 1 || count > 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;

    stkp = ARG_STK(0);
    stkp1 = ARG_STK(1);

    if (stkp1) { /* kind */
      dtyper = set_kind_result(stkp1, DT_REAL, TY_REAL);
      if (!dtyper) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    } else {
      switch (DTY(DDTG(SST_DTYPEG(stkp)))) {
      case TY_CMPLX:
        dtyper = stb.user.dt_real;
        break;
      case TY_DCMPLX:
        dtyper = DT_REAL8;
        (void)mk_coercion_func(dtyper);
        break;
      case TY_QCMPLX:
        dtyper = DT_QUAD;
        (void)mk_coercion_func(dtyper);
        break;
      default:
        dtyper = stb.user.dt_real; /* default real */
        break;
      }
    }

    /* f2003 says that a boz literal can appear as an argument to
     * the real, dble, cmplx, and dcmplx intrinsics and its value
     * is used as the respective internal respresentation
     */
    if (SST_ISNONDECC(stkp) || SST_DTYPEG(stkp) == DT_DWORD)
      cngtyp(stkp, dtyper);
    dtype1 = DDTG(SST_DTYPEG(stkp));
    if (!DT_ISNUMERIC(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    /* If this is f90, leave the kind argument in. Otherwise issue
     * a warning and leave it -- we'll get to it someday
     */
    if (is_sst_const(stkp)) {
      con1 = get_sst_cval(stkp);
      conval = cngcon(con1, dtype1, dtyper);
      goto const_return;
    }
    (void)mkexpr(stkp);
    shaper = SST_SHAPEG(stkp);
    XFR_ARGAST(0);
    argt_count = 1;
    if (stkp1) {
      (void)mkexpr(stkp1);
      argt_count = 2;
      ARG_AST(1) = mk_cval1(target_kind(dtyper), DT_INT4);
    }
    if (shaper)
      dtyper = get_array_dtype(1, dtyper);
    goto gen_call;

  case PD_char:
    if (count < 1 || count > 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    if (SST_ISNONDECC(stkp))
      cngtyp(stkp, DT_INT);
    dtype1 = DDTG(SST_DTYPEG(stkp));
    if (!DT_ISINT(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    dtyper = DT_CHAR;          /* default char */
    if ((stkp = ARG_STK(1))) { /* kind */
      dtyper = set_kind_result(stkp, DT_CHAR, TY_CHAR);
      if (!dtyper) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    }

    /* If this is f90, leave the kind argument in. Otherwise issue
     * a warning and leave it -- we'll get to it someday
     */
    stkp = ARG_STK(0);
    if (is_sst_const(stkp)) {
      con1 = get_sst_cval(stkp);
      if (SST_DTYPEG(stkp) == DT_INT8)
        /* con1 is an sptr */
        con1 = get_int_cval(con1);
      ch = con1;
      conval = getstring(&ch, 1);
      goto const_return;
    }

    if (sem.dinit_data) {
      if (dtyper == DT_CHAR)
        dtyper = get_type(2, TY_CHAR, astb.i1);
      gen_init_intrin_call(stktop, pdsym, count, dtyper, TRUE);
      return 0;
    }
    (void)mkexpr(ARG_STK(0));
    shaper = SST_SHAPEG(ARG_STK(0));
    XFR_ARGAST(0);
    argt_count = 1;
    if (shaper)
      dtyper = get_array_dtype(1, dtyper);
    goto gen_call;

  const_return:
    SST_IDP(stktop, S_CONST);
    SST_DTYPEP(stktop, dtyper);
    SST_CVALP(stktop, conval);
    EXPSTP(pdsym, 1); /* freeze generic or specific name */
    SST_SHAPEP(stktop, 0);
    ast = mk_cval1(conval, dtyper);
    SST_ASTP(stktop, ast);
    return conval;

  const_default_int_return:
    SST_IDP(stktop, S_CONST);
    SST_DTYPEP(stktop, dtyper);
    /* call cngcon to convert the constant from type native integer to the
     * user defined integer type -- if the types are the same cngcon will
     * just return.
     */
    conval = cngcon(conval, DT_INT, dtyper);
    SST_CVALP(stktop, conval);
    EXPSTP(pdsym, 1); /* freeze generic or specific name */
    SST_SHAPEP(stktop, 0);
    ast = mk_cval1(conval, dtyper);
    SST_ASTP(stktop, ast);
    return conval;

  case PD_logical:
    if (count < 1 || count > 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    dtype1 = DDTG(SST_DTYPEG(stkp));
    if (!DT_ISLOG(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    dtyper = stb.user.dt_log;  /* default logical */
    if ((stkp = ARG_STK(1))) { /* kind */
      dtyper = set_kind_result(stkp, DT_LOG, TY_LOG);
      if (!dtyper) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    }
    (void)mkexpr(ARG_STK(0));
    cngtyp(ARG_STK(0), dtyper);
    XFR_ARGAST(0);
    stkp = ARG_STK(0);
    shaper = SST_SHAPEG(stkp);
    ast = ARG_AST(0);
    if (dtype1 != dtyper) {
      argt_count = 1;
      goto gen_call;
    }
    goto expr_val;

  case PD_maxexponent:
  case PD_minexponent:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    dtype1 = DDTG(SST_DTYPEG(ARG_STK(0)));
    switch (DTY(dtype1)) {
    case TY_REAL:
      conval = pdtype == PD_maxexponent ? 128 : -125;
      break;
    case TY_DBLE:
      if (XBIT(49, 0x40000)) /* C90 */
        conval = pdtype == PD_maxexponent ? 8189 : -8188;
      else
        conval = pdtype == PD_maxexponent ? 1024 : -1021;
      break;
    case TY_QUAD:
      if (XBIT(49, 0x40000)) /* C90 */
        conval = pdtype == PD_maxexponent ? 8189 : -8188;
      else
        conval = pdtype == PD_maxexponent ? 16384 : -16381;
    default:
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    goto const_default_int_val; /*return default integer*/

  case PD_nearest:
    if (count != 2) {
      E74_CNT(pdsym, count, 2, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    shaper = SST_SHAPEG(stkp);
    dtype1 = DDTG(SST_DTYPEG(stkp));
    dtype2 = DDTG(SST_DTYPEG(ARG_STK(1)));
    if (!DT_ISREAL(dtype1) || !DT_ISREAL(dtype2)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    shape2 = SST_SHAPEG(ARG_STK(1));
    shaper = set_shape_result(shaper, shape2);
    if (shaper < 0) {
      E74_ARG(pdsym, 2, NULL);
      goto call_e74_arg;
    }
    ast = ARG_AST(1);
    if (shape2)
      dtyper = get_array_dtype(1, DT_LOG);
    else
      dtyper = DT_LOG;
    if (DTY(dtype2) == TY_REAL)
      ast = mk_binop(OP_GE, ast, mk_cnst(stb.flt0), dtyper);
    else
      ast = mk_binop(OP_GE, ast, mk_cnst(stb.dbl0), dtyper);
    ARG_AST(1) = ast;
    if (DTY(dtype1) == TY_REAL)
      rtlRtn = RTE_nearest;
    else /* TY_DBLE */
      rtlRtn = RTE_nearestd;
    (void)sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtype1);
    dtyper = SST_DTYPEG(stkp);
    if (shaper && DTY(dtyper) != TY_ARRAY)
      dtyper = get_array_dtype(1, dtyper);
    break;

  case PD_precision:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    dtype1 = DDTG(SST_DTYPEG(ARG_STK(0)));
    switch (DTY(dtype1)) {
    /* values for real/double taken from float.h <type>_DIG */
    case TY_REAL:
    case TY_CMPLX:
      conval = 6;
      break;
    case TY_DBLE:
    case TY_DCMPLX:
      if (XBIT(49, 0x40000)) /* C90 */
        conval = 13;
      else
        conval = 15;
      break;
    case TY_QCMPLX:
    case TY_QUAD:
      if (XBIT(49, 0x40000)) /* C90 */
        conval = 28;
      else
        conval = 33;
      break;
    default:
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    goto const_default_int_val; /*return default integer*/

  case PD_radix:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    dtype1 = DDTG(SST_DTYPEG(ARG_STK(0)));
    switch (DTY(dtype1)) {
    case TY_BINT:
    case TY_SINT:
    case TY_INT:
    case TY_INT8:
    case TY_REAL:
    case TY_DBLE:
      conval = 2;
      break;
    default:
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    goto const_default_int_val; /*return default integer*/

  case PD_range:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    dtype1 = DDTG(SST_DTYPEG(ARG_STK(0)));
    switch (DTY(dtype1)) {
    case TY_BINT:
      conval = 2;
      break;
    case TY_SINT:
      conval = 4;
      break;
    case TY_INT:
      conval = 9;
      break;
    case TY_INT8:
      conval = 18;
      break;
    case TY_REAL:
    case TY_CMPLX:
      conval = 37;
      break;
    case TY_DBLE:
    case TY_DCMPLX:
      if (XBIT(49, 0x40000)) /* C90 */
        conval = 2465;
      else
        conval = 307;
      break;
    case TY_QUAD:
    case TY_QCMPLX:
      if (XBIT(49, 0x40000)) /* C90 */
        conval = 2465;
      else
        conval = 4931;
      break;
    default:
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    goto const_default_int_val; /*return default integer*/

  case PD_scale:
  case PD_set_exponent:
    if (count != 2) {
      E74_CNT(pdsym, count, 2, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    dtyper = SST_DTYPEG(stkp);
    shaper = SST_SHAPEG(stkp);
    dtype1 = DDTG(dtyper);
    if (!DT_ISREAL(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    dtype2 = SST_DTYPEG(ARG_STK(1));
    if (!DT_ISINT(DDTG(dtype2))) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    shape1 = SST_SHAPEG(ARG_STK(1));
    shaper = set_shape_result(shaper, shape1);
    if (shaper < 0) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    if (shaper && DTY(dtyper) != TY_ARRAY)
      dtyper = get_array_dtype(1, dtyper);
    if (DTY(dtype1) == TY_REAL) {
      if (pdtype == PD_scale)
        rtlRtn = RTE_scale;
      else
        rtlRtn = RTE_setexp;
    } else { /* TY_DBLE */
      if (pdtype == PD_scale)
        rtlRtn = RTE_scaled;
      else
        rtlRtn = RTE_setexpd;
    }
    (void)sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtype1);
    break;

  case PD_tiny:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    dtype1 = DDTG(SST_DTYPEG(ARG_STK(0)));
    switch (DTY(dtype1)) {
    case TY_REAL:
      /* 1.175494351E-38 */
      val[0] = 0x00800000; /* was 0x00400000 */
      sname = "tiny(1.0_4)";
      goto const_real_val;
    case TY_DBLE:
      if (XBIT(49, 0x40000)) {            /* C90 */
#define C90_TINY "0.73344154702194e-2465" /* 0200044000000000000000 */
        atoxd(C90_TINY, &val[0], strlen(C90_TINY));
      } else {
        /* 2.22507385850720138E-308 */
        val[0] = 0x00100000; /* was 0x00080000 */
        val[1] = 0x00000000;
      }
      sname = "tiny(1.0_8)";
      if (XBIT(51, 0x10))
        goto const_dword_val;
      goto const_dble_val;
    default:
      break;
    }
    E74_ARG(pdsym, 0, NULL);
    goto call_e74_arg;

  case PD_index:
#ifdef PD_kindex
  case PD_kindex:
#endif
    if (count < 2 || count > 4) {
      E74_CNT(pdsym, count, 2, 4);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 4, KWDARGSTR(pdsym)))
      goto exit_;

    stkp = ARG_STK(0); /* string */
    if (DTY(DDTG(SST_DTYPEG(stkp))) != TY_CHAR &&
        DTY(DDTG(SST_DTYPEG(stkp))) != TY_NCHAR) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    shaper = SST_SHAPEG(stkp);
    stkp = ARG_STK(1); /* substring */
    if (DTY(DDTG(SST_DTYPEG(stkp))) != TY_CHAR &&
        DTY(DDTG(SST_DTYPEG(stkp))) != TY_NCHAR) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    shape1 = SST_SHAPEG(stkp);
    shaper = set_shape_result(shaper, shape1);
    if (shaper < 0) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    if ((stkp = ARG_STK(2))) { /* back */
      dtype2 = SST_DTYPEG(stkp);
      if (!DT_ISLOG(DDTG(dtype2))) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
      shape2 = SST_SHAPEG(stkp);
      shaper = set_shape_result(shaper, shape2);
      if (shaper < 0) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
    } else
      ARG_AST(2) = mk_cval((INT)SCFTN_FALSE, DT_LOG);

    dtyper = stb.user.dt_int;
    if ((stkp = ARG_STK(3))) { /* kind */
      dtyper = set_kind_result(stkp, DT_INT, TY_INT);
      if (!dtyper) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
    }

    if (A_ALIASG(ARG_AST(0)) && A_ALIASG(ARG_AST(1)) && A_ALIASG(ARG_AST(2))) {
      conval =
          _index(A_SPTRG(A_ALIASG(ARG_AST(0))), A_SPTRG(A_ALIASG(ARG_AST(1))),
                 A_SPTRG(A_ALIASG(ARG_AST(2))));
      goto const_kind_int_val; /*return kind,default integer*/
    }

    if (sem.dinit_data) {
      gen_init_intrin_call(stktop, pdsym, count, dtyper, TRUE);
      return 0;
    }

    hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(RTE_indexa), dtyper);

    argt_count = 4;
    /* pass the kind of the logical argument back */
    ARG_AST(3) = (mk_cval(size_of(DDTG(A_DTYPEG(ARG_AST(2)))), astb.bnd.dtype));

    if (shaper)
      dtyper = get_array_dtype(1, dtyper);

    break;

  case PD_repeat:
    if (count != 2) {
      E74_CNT(pdsym, count, 2, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0); /* string */
    dtype1 = SST_DTYPEG(stkp);
    if (DTY(dtype1) != TY_CHAR && DTY(dtype1) != TY_NCHAR) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    stkp = ARG_STK(1); /* ncopies */
    dtype2 = SST_DTYPEG(stkp);
    if (!DT_ISINT(dtype2)) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }

    ast = ARG_AST(1);
    if (A_ALIASG(ARG_AST(0)) && A_ALIASG(ast)) {
      sptr = _repeat(A_SPTRG(A_ALIASG(ARG_AST(0))), A_SPTRG(A_ALIASG(ast)));
      goto const_str_val;
    }
    if (sem.dinit_data) {
      int ncopies = get_int_cval(A_SPTRG(A_ALIASG(ast)));
      int cvlen = string_length(dtype1);
      int dtypeintr =
          get_type(2, DTYG(dtype1), mk_cval(ncopies * cvlen, stb.user.dt_int));
      gen_init_intrin_call(stktop, pdsym, count, dtypeintr, FALSE);
      return 0;
    }
    ARG_AST(2) = mk_cval(size_of(DDTG(A_DTYPEG(ast))), astb.bnd.dtype);

    ast = mk_id(get_temp(DT_INT));
    if (dtype1 != DT_ASSCHAR && dtype1 != DT_ASSNCHAR) {
      tmp = DTY(dtype1 + 1);
    } else {
      sptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_lena), DT_INT);
      tmp = begin_call(A_FUNC, sptr, 1);
      add_arg(ARG_AST(0));
    }
    tmp = mk_binop(OP_MUL, tmp, ARG_AST(1), DT_INT);
    tmp = mk_assn_stmt(ast, tmp, DT_INT);
    (void)add_stmt(tmp);

    if (DTY(dtype1) == TY_CHAR) {
      hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(RTE_repeata), astb.bnd.dtype);
      dtyper = get_type(2, TY_CHAR, ast);
    } else {
      hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(RTE_nrepeat), DT_INT);
      dtyper = get_type(2, TY_NCHAR, ast);
    }
    arrtmp_ast = mk_id(get_ch_temp(dtyper));
    func_ast = begin_call(A_CALL, hpf_sym, 4);
    add_arg(arrtmp_ast);
    add_arg(ARG_AST(0));
    add_arg(ARG_AST(1));
    add_arg(ARG_AST(2));
    (void)add_stmt(func_ast);
    ast = mk_substr(arrtmp_ast, 0, ast, dtype1);
    shaper = 0;
    goto expr_val;

  case PD_len:
    if (count == 0 || count > 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    dont_issue_assumedsize_error = 1;
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    dont_issue_assumedsize_error = 0;
    if ((stkp = ARG_STK(1))) { /* KIND */
      dtyper = set_kind_result(stkp, DT_INT, TY_INT);
      if (!dtyper) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    } else {
      dtyper = stb.user.dt_int;
    }
    goto len_shared;

#ifdef PD_klen
  case PD_klen:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    dont_issue_assumedsize_error = 1;
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    dont_issue_assumedsize_error = 0;
    dtyper = DT_INT8;
#endif
  len_shared:
    stkp = ARG_STK(0);
    dtype1 = DDTG(SST_DTYPEG(stkp));
    if (DTY(dtype1) != TY_CHAR && DTY(dtype1) != TY_NCHAR) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    ast = ARG_AST(0);
    if (A_TYPEG(ast) == A_INTR) {
      switch (A_OPTYPEG(ast)) {
      case I_ADJUSTL: /* adjustl(string) */
      case I_ADJUSTR: /* adjustr(string) */
        /*  len is just len(string) */
        ast = ARGT_ARG(A_ARGSG(ast), 0);
        ARG_AST(0) = ast;
        break;
      }
    }
    if (A_ALIASG(ast)) {
      conval = string_length(dtype1);
      goto const_kind_int_val; /*return dtyper integer*/
    }
    switch (A_TYPEG(ast)) {
      int clen;
      int sym = 0;
    case A_ID:
    case A_MEM:
    case A_SUBSCR:
#ifdef USELENG
      sym = memsym_of_ast(ast);
      if (A_TYPEG(ast) == A_MEM && LENG(sym) && USELENG(sym)) {
        if (SETKINDG(sym) && !USEKINDG(sym)) {
          clen = LENG(sym);
        } else {
          clen = get_len_parm_by_number(LENG(sym), ENCLDTYPEG(sym), 0);
        }
        if (clen) {
          clen = mk_member(A_PARENTG(ast), clen, ENCLDTYPEG(sym));
        } else {
          clen = DTY(dtype1 + 1);
        }
      } else
#endif
      {
        if (!sym)
          sym = memsym_of_ast(ast);
        if (ADJLENG(sym)) {
          clen = mk_id(CVLENG(sym));
        } else {
          clen = DTY(dtype1 + 1);
        }
      }
      if (clen && A_ALIASG(clen)) {
        /* not assumed-size */
        conval = string_length(dtype1);
        goto const_kind_int_val; /*return dtyper integer*/
      } else if (clen) {
        ast = clen;
        goto expr_val;
      }
      break;
    }
    if (DTY(SST_DTYPEG(stkp)) == TY_ARRAY) {
      if (pdtype == PD_len) {
        hpf_sym =
            sym_mkfunc_nodesc_expst(mkRteRtnNm(RTE_lena), stb.user.dt_int);
        /*
         * need to generete the call here since gen_call assumes that
         * the type of result of the function is the type of the
         * intrinsic.
         */
        argt = mk_argt(1);
        ARGT_ARG(argt, 0) = ARG_AST(0);
        func_ast = mk_id(hpf_sym);
        ast = mk_func_node(A_FUNC, func_ast, 1, argt);
        A_DTYPEP(ast, stb.user.dt_int);
        A_DTYPEP(func_ast, stb.user.dt_int);
        if (dtyper != stb.user.dt_int)
          ast = mk_convert(ast, dtyper);
        goto expr_val;
      }
      hpf_sym = sym_mkfunc_nodesc_expst(mkRteRtnNm(RTE_lena), DT_INT8);
      func_type = A_FUNC;
    }
    argt_count = 1;
    break;

  case PD_len_trim:
    if (count < 1 || count > 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;

    stkp = ARG_STK(0);
    dtype1 = DDTG(SST_DTYPEG(stkp));
    shaper = SST_SHAPEG(stkp);
    if (DTY(dtype1) != TY_CHAR && DTY(dtype1) != TY_NCHAR) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    dtyper = stb.user.dt_int;
    if ((stkp = ARG_STK(1))) {
      dtyper = set_kind_result(stkp, DT_INT, TY_INT);
      if (!dtyper) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    }
    ast = ARG_AST(0);
    if (A_ALIASG(ast)) {
      conval = _len_trim(A_SPTRG(A_ALIASG(ast)));
      goto const_kind_int_val;
    }
    if (sem.dinit_data) {
      gen_init_intrin_call(stktop, pdsym, count, dtyper, FALSE);
      return 0;
    }
    argt_count = 1;
    if (shaper)
      dtyper = get_array_dtype(1, dtyper);
    break;

  case PD_trim:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0);
    dtype1 = SST_DTYPEG(stkp);
    if (DTY(dtype1) != TY_CHAR && DTY(dtype1) != TY_NCHAR) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if (A_ALIASG(ARG_AST(0))) {
      sptr = _trim(A_SPTRG(A_ALIASG(ARG_AST(0))));
      goto const_str_val;
    }
    if (sem.dinit_data) {
      gen_init_intrin_call(stktop, pdsym, count, dtype1, FALSE);
      return 0;
    }
    if (DTY(dtype1) == TY_CHAR)
      dtyper = DT_ASSCHAR;
    else
      dtyper = DT_ASSNCHAR;
    /* check if the dtype warrants an allocatable temp; if so,
     * need indicate this so that if the context is a relational
     * expression, the expression will be evaluated an assigned
     * to a temp.
     */
    (void)need_alloc_ch_temp(dtyper);
    break;

  case PD_transfer:
    if (count < 2 || count > 3) {
      E74_CNT(pdsym, count, 2, 3);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 3, KWDARGSTR(pdsym)))
      goto exit_;
    argt_count = 3;

    stkp = ARG_STK(1); /* mold */
    dtyper = SST_DTYPEG(stkp);
    shaper = SST_SHAPEG(stkp);

    if ((stkp = ARG_STK(2))) { /* size */
      dtype2 = SST_DTYPEG(stkp);
      if (!DT_ISINT(dtype2)) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
    }

    if (sem.dinit_data) {
      /* If the result is array-valued, we need to determine its type. */
      if (shaper != 0 || stkp != NULL) {
        int size_ast;
        ISZ_T size;

        if (stkp != NULL)
          size_ast = ARG_AST(2); /* use size */
        else {
          /* No size specified.
           * Make result big enough to hold all of source.
           */
          size = size_of(DDTG(dtyper));
          size = (size_of(SST_DTYPEG(ARG_STK(0))) + size - 1) / size;
          size_ast = mk_isz_cval(size, astb.bnd.dtype);
        }
        add_shape_rank(1);
        add_shape_spec(astb.bnd.one, size_ast, astb.bnd.one);
        shaper = mk_shape();
        if (DTY(dtyper) != TY_ARRAY)
          dtyper = get_array_dtype(1, dtyper);
        dtyper = dtype_with_shape(dtyper, shaper);
        ADD_NUMELM(dtyper) = size_ast;
      }
      gen_init_intrin_call(stktop, pdsym, argt_count, dtyper, FALSE);
      return 0;
    }

    if (shaper == 0 && stkp == NULL) {
      /* result is the 'scalar' type of mold */
      shaper = 0;
      dtyper = DDTG(dtyper);
    } else {
      tmp = getcctmp_sc('d', sem.dtemps++, ST_VAR, astb.bnd.dtype, sem.sc);
      add_shape_rank(1);
      add_shape_spec(astb.bnd.one, mk_id(tmp), astb.bnd.one);
      shaper = mk_shape();
      if (DTY(dtyper) != TY_ARRAY)
        dtyper = get_array_dtype(1, dtyper);
      if (stkp != NULL)
        ast = ARG_AST(2); /* use size */
      else {
        /* else compute size by the expression
         *   (t1 + t2 - 1) / t2
         *
         * t1 = (#elements source) * size_of(element type of source)
         * t2 = size_of(element type of mold).
         */
        int t1, t2;
        t1 = size_of_ast(ARG_AST(0)); /* #elements in source */
        t1 = mk_binop(OP_MUL, t1, elem_size_of_ast(ARG_AST(0)), astb.bnd.dtype);
        t2 = elem_size_of_ast(ARG_AST(1));
        ast = mk_binop(OP_ADD, t1, t2, astb.bnd.dtype);
        ast = mk_binop(OP_SUB, ast, astb.bnd.one, astb.bnd.dtype);
        ast = mk_binop(OP_DIV, ast, t2, astb.bnd.dtype);
      }
      ast = mk_assn_stmt(mk_id(tmp), ast, astb.bnd.dtype);
      (void)add_stmt(ast);
    }
    break;

  case PD_scan:
  case PD_verify:
    if (count < 2 || count > 4) {
      E74_CNT(pdsym, count, 2, 4);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 4, KWDARGSTR(pdsym)))
      goto exit_;
    argt_count = 3;

    stkp = ARG_STK(0); /* string */
    dtype1 = DDTG(SST_DTYPEG(stkp));
    if (DTY(dtype1) != TY_CHAR && DTY(dtype1) != TY_NCHAR) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    shaper = SST_SHAPEG(stkp);

    stkp = ARG_STK(1); /* set */
    if (DTY(DDTG(SST_DTYPEG(stkp))) != DTY(dtype1)) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    shape1 = SST_SHAPEG(stkp);
    shaper = set_shape_result(shaper, shape1);
    if (shaper < 0) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }

    dtype2 = DT_LOG;
    if ((stkp = ARG_STK(2))) { /* back */
      ast = ARG_AST(2);
      dtype2 = SST_DTYPEG(stkp);
      if (!DT_ISLOG(DDTG(dtype2))) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
      shape2 = SST_SHAPEG(stkp);
      shaper = set_shape_result(shaper, shape2);
      if (shaper < 0) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
    } else
      ast = mk_cval((INT)SCFTN_FALSE, DT_LOG);

    dtyper = stb.user.dt_int;
    if ((stkp = ARG_STK(3))) { /* kind */
      dtyper = set_kind_result(stkp, DT_INT, TY_INT);
      if (!dtyper) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
    }

    if (DTY(dtype1) == TY_CHAR && A_ALIASG(ARG_AST(0)) &&
        A_ALIASG(ARG_AST(1)) && A_ALIASG(ast)) {
      if (pdtype == PD_verify)
        conval = _verify(A_SPTRG(A_ALIASG(ARG_AST(0))),
                         A_SPTRG(A_ALIASG(ARG_AST(1))), A_SPTRG(A_ALIASG(ast)));
      else
        conval = _scan(A_SPTRG(A_ALIASG(ARG_AST(0))),
                       A_SPTRG(A_ALIASG(ARG_AST(1))), A_SPTRG(A_ALIASG(ast)));
      goto const_kind_int_val; /*return default integer*/
    }

    if (sem.dinit_data) {
      gen_init_intrin_call(stktop, pdsym, count, dtyper, TRUE);
      return 0;
    }

    ARG_AST(2) = ast;
    ARG_AST(3) = mk_cval(size_of(DDTG(dtype2)), astb.bnd.dtype);
    argt_count = 4;
    if (DTY(dtype1) == TY_CHAR) {
      if (pdtype == PD_verify)
        rtlRtn = RTE_verifya;
      else
        rtlRtn = RTE_scana;
    } else { /* TY_NCHAR */
      if (pdtype == PD_verify)
        rtlRtn = RTE_nverify;
      else
        rtlRtn = RTE_nscan;
    }

    hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtyper);

    if (shaper)
      dtyper = get_array_dtype(1, dtyper);
    break;

  case PD_ilen:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0); /* i */
    dtyper = SST_DTYPEG(stkp);
    shaper = SST_SHAPEG(stkp);
    dtype1 = DDTG(dtyper);
    if (!DT_ISINT(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if (is_sst_const(stkp)) {
      /*
       * if i is nonnegative,
       *     ilen(i) = ceiling(log2(i+1))
       * if i is negative,
       *     ilen(i) = ceiling(log2(-i))
       */
      INT tmp[2];
      INT zero[2];
      INT vval[2];
      int len;
      int i;

      con1 = get_sst_cval(stkp);
      if (DTY(dtype1) == TY_INT8 || DTY(dtype1) == TY_LOG8) {
        val[0] = CONVAL1G(con1);
        val[1] = CONVAL2G(con1);
      } else {
        if (con1 < 0)
          val[0] = -1;
        else
          val[0] = 0;
        val[1] = con1;
      }
      zero[0] = zero[1] = 0;
      if (cmp64(val, zero) < 0)
        neg64(val, val);
      else {
        tmp[0] = 0;
        tmp[1] = 1;
        add64(val, tmp, val);
      }
      vval[0] = val[0];
      vval[1] = val[1];
      len = -1;
      while (cmp64(val, zero) != 0) {
        ushf64((UINT *)val, -1, (UINT *)val);
        ++len;
      }
      tmp[0] = 0;
      tmp[1] = 1;
      shf64(tmp, len, tmp);
      /* if number is larger than 2**(bit pos), increase by one */
      xor64(tmp, vval, tmp);
      if (cmp64(tmp, zero) != 0)
        ++len;
      conval = len;
      goto const_default_int_val; /*return default integer*/
    }
    (void)mkexpr(ARG_STK(0));
    XFR_ARGAST(0);
    ast = ARG_AST(0);
    ARG_AST(1) = mk_cval(size_of(DDTG(A_DTYPEG(ast))), astb.bnd.dtype);
    argt_count = 2;
    fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_ilen), astb.bnd.dtype);
    EXTSYMP(pdsym, fsptr);
    break;

  case PD_processors_shape:
    if (count) {
      E74_CNT(pdsym, count, 0, 0);
      goto call_e74_cnt;
    }
    tmp = getcctmp_sc('d', sem.dtemps++, ST_VAR, DT_INT, sem.sc);
    add_shape_rank(1);
    add_shape_spec(astb.i1, mk_id(tmp), astb.i1);
    shaper = mk_shape();
    dtyper = aux.dt_iarray;

    sptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_processors_rank), stb.user.dt_int);
    ast = mk_func_node(A_FUNC, mk_id(sptr), 0, 0);
    A_DTYPEP(ast, DT_INT);

    ast = mk_assn_stmt(mk_id(tmp), ast, DT_INT);

    (void)add_stmt(ast);

    argt_count = 0;
    break;

  case PD_same_type_as:
  case PD_extends_type_of: {
    int dt1, dt2, sptrsdsc, argsptr, argsptr2, fsptr, flag, mast1, mast2;
    int decl1, decl2, flag_con;
    static int tmp = 0;

    if (count != 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;

    dt1 = A_DTYPEG(ARG_AST(0));
    dt2 = A_DTYPEG(ARG_AST(1));
    if (DTY(dt1) == TY_ARRAY) {
      dt1 = DTY(dt1 + 1);
    }

    if (DTY(dt2) == TY_ARRAY) {
      dt2 = DTY(dt2 + 1);
    }

    if (DTY(dt1) != TY_DERIVED) {
      /* TBD - Probably need to fix this condition when we implement
       * unlimited polymorphic types.
       */
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if (DTY(dt2) != TY_DERIVED) {
      /* TBD - Probably need to fix this condition when we implement
       * unlimited polymorphic types.
       */
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }

    mast1 = ARG_AST(0);
    if (A_TYPEG(mast1) == A_SUBSCR) {
      /* To avoid lower error - bad OP type */
      mast1 = A_LOPG(mast1);
    }
    argsptr = memsym_of_ast(mast1);
    mast2 = ARG_AST(1);
    if (A_TYPEG(mast2) == A_SUBSCR) {
      /* To avoid lower error - bad OP type */
      mast2 = A_LOPG(mast2);
    }
    argsptr2 = memsym_of_ast(mast2);
    if (!CLASSG(argsptr) && !CLASSG(argsptr2)) {
      /* we can statically compute the type comparison */
      flag = eq_dtype2(dt2, dt1, (pdtype == PD_extends_type_of));
      if (flag)
        flag = gbl.ftn_true;
      ast = mk_cval1(flag, DT_INT);
      goto finish_type_cmp;
    }

    argt = mk_argt(7);
    ARGT_ARG(argt, 0) = mast1;
    ARGT_ARG(argt, 2) = mast2;

    if (CLASSG(argsptr)) {
      if (POINTERG(argsptr)) {
        flag = 1;
      } else if (ALLOCATTRG(argsptr)) {
        flag = 2;
      } else {
        flag = 0;
      }
    } else {
      flag = 0;
    }

    if (flag & (1 | 2)) {
      /* get declared type of arg1 */
      decl1 = getccsym('D', tmp++, ST_VAR);
      DTYPEP(decl1, DTYPEG(argsptr));
      decl1 = get_static_type_descriptor(decl1);
    } else {
      decl1 = 0;
    }

    if (CLASSG(argsptr) && STYPEG(argsptr) == ST_MEMBER) {
      int newargt2, astnew, func;
      int src_ast, std;
      int sdsc_mem = get_member_descriptor(argsptr);
      if (CLASSG(argsptr)) {
        sptrsdsc = get_type_descr_arg(gbl.currsub, argsptr);
      } else {
        sptrsdsc = getccsym('D', tmp++, ST_VAR);
        DTYPEP(sptrsdsc, DTYPEG(argsptr));
        sptrsdsc = get_static_type_descriptor(sptrsdsc);
      }
      ARGT_ARG(argt, 1) = mk_id(sptrsdsc);

      src_ast = mk_member(A_PARENTG(mast1), mk_id(sdsc_mem), A_DTYPEG(mast1));
      std = add_stmt(mk_stmt(A_CONTINUE, 0));
      gen_set_type(mk_id(sptrsdsc), src_ast, std, FALSE, FALSE);
    } else {
      if (CLASSG(argsptr)) {
        sptrsdsc = get_type_descr_arg(gbl.currsub, argsptr);
      } else {
        sptrsdsc = getccsym('D', tmp++, ST_VAR);
        DTYPEP(sptrsdsc, DTYPEG(argsptr));
        sptrsdsc = get_static_type_descriptor(sptrsdsc);
      }
      ARGT_ARG(argt, 1) = mk_id(sptrsdsc);
    }

    if (CLASSG(argsptr2)) {
      if (POINTERG(argsptr2)) {
        flag |= 4;
      } else if (ALLOCATTRG(argsptr2)) {
        flag |= 8;
      }
    }

    if (flag & (4 | 8)) {
      /* get declared type of arg2 */
      decl2 = getccsym('D', tmp++, ST_VAR);
      DTYPEP(decl2, DTYPEG(argsptr2));
      decl2 = get_static_type_descriptor(decl2);
    } else {
      decl2 = 0;
    }
    if (CLASSG(argsptr2) && STYPEG(argsptr2) == ST_MEMBER) {
      int newargt2, func, astnew;
      int src_ast, std;
      int sdsc_mem = get_member_descriptor(argsptr2);
      if (CLASSG(argsptr2)) {
        sptrsdsc = get_type_descr_arg(gbl.currsub, argsptr2);
      } else {
        sptrsdsc = getccsym('D', tmp++, ST_VAR);
        DTYPEP(sptrsdsc, DTYPEG(argsptr2));
        sptrsdsc = get_static_type_descriptor(sptrsdsc);
      }

      ARGT_ARG(argt, 3) = mk_id(sptrsdsc);
      src_ast = mk_member(A_PARENTG(mast2), mk_id(sdsc_mem), A_DTYPEG(mast2));
      std = add_stmt(mk_stmt(A_CONTINUE, 0));
      gen_set_type(mk_id(sptrsdsc), src_ast, std, FALSE, FALSE);

    } else {
      if (CLASSG(argsptr2)) {
        sptrsdsc = get_type_descr_arg(gbl.currsub, argsptr2);
      } else {
        sptrsdsc = getccsym('D', tmp++, ST_VAR);
        DTYPEP(sptrsdsc, DTYPEG(argsptr2));
        sptrsdsc = get_static_type_descriptor(sptrsdsc);
      }

      ARGT_ARG(argt, 3) = mk_id(sptrsdsc);
    }

    flag_con = mk_cval1(flag, DT_INT);
    flag_con = mk_unop(OP_VAL, flag_con, DT_INT);
    ARGT_ARG(argt, 4) = flag_con;
    argt_count = 5;
    if (decl1) {
      ARGT_ARG(argt, 5) = mk_id(decl1);
      ++argt_count;
    }
    if (decl2) {
      ARGT_ARG(argt, argt_count) = mk_id(decl2);
      ++argt_count;
    }
    if (pdtype == PD_extends_type_of) {
      if (XBIT(68, 0x1)) {
        fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_extends_type_of), DT_LOG);
      } else
        fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_extends_type_of), DT_LOG);
    } else {
      if (XBIT(68, 0x1)) {
        fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_same_type_as), DT_LOG);

      } else
        fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_same_type_as), DT_LOG);
    }
    func_ast = mk_id(fsptr);
    ast = mk_func_node(A_FUNC, func_ast, argt_count, argt);
  finish_type_cmp:
    dtyper = stb.user.dt_log;
    A_DTYPEP(ast, dtyper);
    A_OPTYPEP(ast, INTASTG(pdsym));
    goto expr_val;
  }
  case PD_associated:
    if (count < 1 || count > 2) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    pvar = find_pointer_variable(ARG_AST(0));
    if (pvar == 0 || !POINTERG(pvar)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if ((stkp = ARG_STK(1))) { /* target */
      find_pointer_target(ARG_AST(1), &baseptr, &sptr);
      /* target may be variable, subarray, or derived-type member;
       * if variable or subarray, it must be POINTER or TARGET.
       * if derived-type member, the base must be a TARGET,
       * or the base or member must be POINTER */
      if (baseptr == 0 || (!TARGETG(baseptr) && !POINTERG(sptr) &&
                           !any_pointer_source(ARG_AST(1)))) {
        if (STYPEG(sptr) != ST_PROC || !is_procedure_ptr(pvar)) {
          E74_ARG(pdsym, 1, NULL);
          goto call_e74_arg;
        }
      }
    }
    argt_count = 2;

    dtyper = stb.user.dt_log;
    break;

  case PD_is_contiguous:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    ast = SST_ASTG(ARG_STK(0));
    if (A_TYPEG(ast) != A_ID && A_TYPEG(ast) != A_MEM) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    i = memsym_of_ast(ast);
    dtype1 = DTYPEG(i);
    if (DTY(dtype1) != TY_ARRAY) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    dtyper = stb.user.dt_log;
    if (CONTIGATTRG(i) || (!ASSUMSHPG(i) && !POINTERG(i))) {
      conval = TRUE;
      goto const_kind_int_val;
    }
    argt_count = 2;
    if (!SDSCG(i)) {
      get_static_descriptor(i);
    }
    ARG_AST(1) = mk_id(SDSCG(i));
    break;

  case PD_ranf:
    if (count > 1) {
      E74_CNT(pdsym, count, 0, 1);
      goto call_e74_cnt;
    }
    argt_count = 0; /* ignore argument if present */
    dtyper = stb.user.dt_real;
    break;
  case PD_ranget:
    if (count > 1) {
      E74_CNT(pdsym, count, 0, 1);
      goto call_e74_cnt;
    }
    if (REFG(pdsym) && !FUNCG(pdsym))
      goto ill_call; /* can be CALL'd, but must be consistent */
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    if ((stkp = ARG_STK(0))) { /* i */
      if (!is_varref(stkp)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(stkp, &dum);
      XFR_ARGAST(0);
      dtype2 = SST_DTYPEG(stkp);
      if (dtype2 != DT_INT) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
    }
    dtyper = DT_DWORD;
    REFP(pdsym, 1);
    FUNCP(pdsym, 1);
    break;
  case PD_ranset:
    if (count > 1) {
      E74_CNT(pdsym, count, 0, 1);
      goto call_e74_cnt;
    }
    if (REFG(pdsym) && !FUNCG(pdsym))
      goto ill_call; /* can be CALL'd, but must be consistent */
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    if ((stkp = ARG_STK(0))) { /* i */
      (void)mkarg(stkp, &dum);
      XFR_ARGAST(0);
      dtype2 = SST_DTYPEG(stkp);
      if (!DT_ISINT(dtype2) && dtype2 != DT_REAL) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
    }
    dtyper = DT_DWORD;
    REFP(pdsym, 1);
    FUNCP(pdsym, 1);
    break;
  case PD_unit:
  case PD_length:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0); /* unit number */
    (void)mkarg(stkp, &dum);
    XFR_ARGAST(0);
    dtype2 = SST_DTYPEG(stkp);
    if (!DT_ISINT(dtype2)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if (pdtype == PD_unit)
      dtyper = DT_REAL;
    else
      dtyper = DT_INT;
    break;

  case PD_int_mult_upper:
    if (count != 2) {
      E74_CNT(pdsym, count, 2, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0); /* i */
    shaper = SST_SHAPEG(stkp);
    dtyper = SST_DTYPEG(stkp);
    dtype1 = DDTG(dtyper);
    if (dtype1 != DT_INT) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    stkp = ARG_STK(1); /* j */
    dtype2 = DDTG(SST_DTYPEG(stkp));
    if (dtype2 != DT_INT) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    shape2 = SST_SHAPEG(stkp);
    if (shaper == 0) {
      /* i is scalar - assume the shape of j */
      shaper = shape2;
      dtyper = SST_DTYPEG(stkp);
    } else if (shape2 && !conform_shape(shaper, shape2)) {
      /* both i and j have shape */
      error(155, 3, gbl.lineno, "Nonconformable arrays passed to intrinsic",
            SYMNAME(pdsym));
      goto exit_;
    }
    break;

  case PD_cot:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0); /* x */
    shaper = SST_SHAPEG(stkp);
    dtyper = SST_DTYPEG(stkp);
    dtype1 = DDTG(dtyper);
    if (!DT_ISREAL(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    break;

  case PD_dcot:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0); /* x */
    shaper = SST_SHAPEG(stkp);
    dtyper = SST_DTYPEG(stkp);
    dtype1 = DDTG(dtyper);
    if (dtype1 != DT_QUAD) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    break;

  case PD_shiftl:
  case PD_shiftr:
    if (count != 2) {
      E74_CNT(pdsym, count, 2, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0); /* i */
    shaper = SST_SHAPEG(stkp);
    dtype1 = DDTG(SST_DTYPEG(stkp));
    if (!DT_ISINT(dtype1) && !DT_ISREAL(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    stkp = ARG_STK(1); /* j */
    dtype1 = DDTG(SST_DTYPEG(stkp));
    if (!DT_ISINT(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if (shaper)
      dtyper = get_array_dtype(SHD_NDIM(shaper), DT_DWORD);
    else
      dtyper = DT_DWORD;
    break;

  case PD_dshiftl:
  case PD_dshiftr:
    if (count != 3) {
      E74_CNT(pdsym, count, 3, 3);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 3, KWDARGSTR(pdsym)))
      goto exit_;
    shaper = 0;
    for (i = 0; i < 3; i++) {
      stkp = ARG_STK(i); /* i, j, k */
      dtype1 = DDTG(SST_DTYPEG(stkp));
      if (!DT_ISINT(dtype1)) {
        E74_ARG(pdsym, i, NULL);
        goto call_e74_arg;
      }
      if (shaper) {
        if ((shape1 = SST_SHAPEG(stkp)) &&
            SHD_NDIM(shaper) != SHD_NDIM(shape1)) {
          E74_ARG(pdsym, i, NULL);
          goto call_e74_arg;
        }
      } else
        shaper = SST_SHAPEG(stkp);
    }
    if (shaper)
      dtyper = get_array_dtype(SHD_NDIM(shaper), DT_INT);
    else
      dtyper = DT_INT;
    break;

  case PD_mask:
  /* Mask is a cray intrinsic */
  like_cray_mask:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0); /* i */
    dtyper = SST_DTYPEG(stkp);
    dtype1 = DDTG(dtyper);
    if (!DT_ISINT(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    shaper = SST_SHAPEG(stkp);
    break;

  case PD_null:
    argt_count = 0;
    if (count > 1) {
      E74_CNT(pdsym, count, 1, 2);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    if (count == 1) {
      if (SST_IDG(ARG_STK(0)) == S_IDENT) {
        sptr = SST_SYMG(ARG_STK(0));
      } else {
        sptr = memsym_of_ast(SST_ASTG(ARG_STK(0)));
      }
      if (!POINTERG(sptr)) {
        errsev(458);
        if (INSIDE_STRUCT) {
          sem.dinit_error = TRUE;
        }
        return (fix_term(stktop, stb.i0));
      }
      dtyper = SST_DTYPEG(ARG_STK(0));
      shaper = SST_SHAPEG(ARG_STK(0));
      argt_count = 1;
    } else {
      dtyper = DT_WORD;
    }
    if (sem.dinit_data || INSIDE_STRUCT) {
      gen_init_intrin_call(stktop, pdsym, count, dtyper, FALSE);
      return 0;
    }
    break;

  case PD_int_ptr_kind:
    if (count) {
      E74_CNT(pdsym, count, 0, 2);
      goto call_e74_cnt;
    }
    conval = size_of(DT_PTR);
    goto const_default_int_val; /*return default integer*/

  case PD_c_sizeof:
  case PD_sizeof:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;

    (void)mkarg(ARG_STK(0), &dum);
    XFR_ARGAST(0);
    ast = ARG_AST(0);

    if (pdtype == PD_c_sizeof) {
      sptr = 0;
      if (A_TYPEG(ast) == A_MEM) {
        sptr = A_SPTRG(A_MEMG(ast));
      } else if (A_TYPEG(ast) == A_ID) {
        sptr = A_SPTRG(ast);
      }
      if (sptr) {
        if (POINTERG(sptr) || ALLOCG(sptr) || CLASSG(sptr) || ASSUMSHPG(sptr) ||
            ASUMSZG(sptr) ||
            (DTY(DTYPEG(sptr)) == TY_DERIVED &&
             !(CFUNCG(DTY(DTYPEG(sptr) + 3)) || is_iso_cptr(DTYPEG(sptr)) ||
               is_iso_c_funptr(DTYPEG(sptr))))) {
          error(4, 3, gbl.lineno,
                "Illegal argument: must be interoperable with a C type", NULL);
          goto exit_;
        }
      }
      dtyper = 0;
      sptr = refsym(getsymbol("c_size_t"), OC_OTHER);
      if (STYPEG(sptr) == ST_PARAM) {
        dtyper =
            select_kind(DT_INT, TY_INT, get_isz_cval(A_SPTRG(CONVAL2G(sptr))));
      } else {
        dtyper = select_kind(DT_INT, TY_INT, 8);
      }
    } else {
      if (XBIT(68, 0x1) && XBIT(68, 0x2))
        dtyper = DT_INT8;
      else
        dtyper = stb.user.dt_int;
    }
    asumsz = 0;
    shaper = 0;
    dtype1 = SST_DTYPEG(ARG_STK(0));
    if (DTY(dtype1) == TY_ARRAY) {
      eltype = DTY(dtype1 + 1);
      /* FIRST, compute SIZE(arg) */
      switch (A_TYPEG(ast)) {
      case A_ID:
        asumsz = A_SPTRG(ast);
        if (SCG(asumsz) != SC_DUMMY || !ASUMSZG(asumsz))
          asumsz = 0;
        break;
      default:
        break;
      }
      sptr = find_pointer_variable(ast);
      if (sptr && (POINTERG(sptr) || (ALLOCG(sptr) && SDSCG(sptr)))) {
        /* pghpf_size(dim, static_descriptor) */
        if (XBIT(68, 0x1))
          hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(RTE_sizeDsc), dtyper);
        else
          hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(RTE_sizeDsc), dtyper);
        nelems = begin_call(A_FUNC, hpf_sym, 2);
        A_DTYPEP(nelems, dtyper);
        add_arg(astb.ptr0);
        add_arg(check_member(ARG_AST(0), mk_id(SDSCG(sptr))));
        goto mul_by_eltype;
      }
      shape1 = A_SHAPEG(ARG_AST(0));
      count = SHD_NDIM(shape1); /* rank of array arg */
      if (asumsz)
        error(84, 3, gbl.lineno, SYMNAME(asumsz),
              "- size of assumed size array is unknown");
      else {
        for (i = 0; i < count; i++) {
          if (SHD_LWB(shape1, i) == 0 || A_ALIASG(SHD_LWB(shape1, i)) == 0 ||
              SHD_UPB(shape1, i) == 0 || A_ALIASG(SHD_UPB(shape1, i)) == 0 ||
              (SHD_STRIDE(shape1, i) != 0 &&
               A_ALIASG(SHD_STRIDE(shape1, i)) == 0)) {
            goto call_size_intr;
          }
        }
        nelems = extent_of_shape(shape1, 0);
        for (i = 1; i < count; i++) {
          int e;
          e = extent_of_shape(shape1, i);
          if (A_ALIASG(e)) { /* should be constant, but ... */
            if (get_isz_cval(A_SPTRG(e)) <= 0) {
              nelems = astb.bnd.zero;
              break;
            }
          } else
            goto call_size_intr;
          nelems = mk_binop(OP_MUL, nelems, e, astb.bnd.dtype);
        }
        goto mul_by_eltype;
      }
    call_size_intr:
      (void)sym_mkfunc_nodesc(mkRteRtnNm(RTE_size), dtyper);
      argt = mk_argt(2);
      ARGT_ARG(argt, 0) = ARG_AST(0);
      ARGT_ARG(argt, 1) = astb.ptr0;
      func_ast = mk_id(intast_sym[I_SIZE]);
      nelems = mk_func_node(A_INTR, func_ast, 2, argt);
      A_DTYPEP(nelems, dtyper);
      A_DTYPEP(func_ast, dtyper);
      A_OPTYPEP(nelems, I_SIZE);
    } else {
      nelems = mk_cval(1, dtyper);
      eltype = dtype1;
    }

  mul_by_eltype:
    if (eltype == DT_ASSCHAR || eltype == DT_ASSNCHAR ||
        eltype == DT_DEFERCHAR || eltype == DT_DEFERNCHAR) {
      ast = ast_intr(I_LEN, dtyper, 1, ast);
    } else
      ast = size_ast_of(ast, eltype);
    ast = mk_binop(OP_MUL, ast, nelems, dtyper);
    if (A_ALIASG(ast)) {
      ast = A_ALIASG(ast);
      iszval = get_isz_cval(A_SPTRG(ast));
      goto const_isz_val;
    }
    goto expr_val;

  case PD_storage_size:
    if (count == 0 || count > 2) {
      E74_CNT(pdsym, count, 1, 3);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;

    if ((stkp = ARG_STK(1))) { /* KIND */
      dtyper = set_kind_result(stkp, DT_INT, TY_INT);
      if (!dtyper) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
    } else {
      dtyper = stb.user.dt_int;
    }

    if (SST_IDG(ARG_STK(0)) == S_IDENT) {
      sptr = SST_SYMG(ARG_STK(0));
    } else {
      sptr = memsym_of_ast(SST_ASTG(ARG_STK(0)));
    }

    dtype1 = DTYPEG(sptr);
    eltype = DTY(dtype1) == TY_ARRAY ? DTY(dtype1 + 1) : dtype1;
    if (CLASSG(sptr)) {
      ast = gen_call_class_obj_size(sptr);
      ast = mk_binop(OP_MUL, ast, mk_cval(BITS_PER_BYTE, DT_INT8), DT_INT8);
      if (dtyper != DT_INT8)
        ast = mk_convert(ast, dtyper);
      goto expr_val;
    } else if (eltype == DT_ASSCHAR || eltype == DT_ASSNCHAR ||
               eltype == DT_DEFERCHAR || eltype == DT_DEFERNCHAR) {
      (void)mkarg(ARG_STK(0), &dum);
      XFR_ARGAST(0);
      ast = ast_intr(I_LEN, dtyper, 1, ARG_AST(0));
      ast = mk_binop(OP_MUL, ast, mk_cval(BITS_PER_BYTE, dtyper), dtyper);
      if (A_ALIASG(ast)) {
        ast = A_ALIASG(ast);
        iszval = get_isz_cval(A_SPTRG(ast));
        goto const_isz_val;
      }
      goto expr_val;
    } else {
      dtype1 = SST_DTYPEG(ARG_STK(0));
      if (DTY(dtype1) == TY_ARRAY) {
        conval = size_of(DTY(dtype1 + 1));
        conval = ALIGN(conval, alignment(dtype1));
      } else {
        conval = size_of(dtype1);
      }
      conval *= BITS_PER_BYTE;
      goto const_kind_int_val;
    }
    break;
  case PD_leadz:
  case PD_popcnt:
  case PD_poppar:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    stkp = ARG_STK(0); /* i */
    dtyper = SST_DTYPEG(stkp);
    dtype1 = DDTG(dtyper);
    if (!DT_ISINT(dtype1)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    shaper = SST_SHAPEG(stkp);
    break;

  case PD_compiler_version:
    if (count != 0) {
      E74_CNT(pdsym, count, 0, 0);
      goto call_e74_cnt;
    }

    sprintf(verstr, "flang %s", get_version_string());
    sptr = getstring(verstr, strlen(verstr));

    goto const_str_val;

  case PD_compiler_options:
    if (count != 0) {
      E74_CNT(pdsym, count, 0, 0);
      goto call_e74_cnt;
    }
    sname = flg.cmdline;
    if (sname != NULL) {
      for (; !isspace(*sname); ++sname)
        ;
      for (; isspace(*sname); ++sname)
        ;
      sptr = getstring(sname, strlen(sname));
    } else {
      interr("compiler_options: command line not available", 0, 3);
    }

    goto const_str_val;

  case PD_command_argument_count:
    if (count != 0) {
      E74_CNT(pdsym, count, 0, 0);
      goto call_e74_cnt;
    }
    dtyper = stb.user.dt_int;
    func_type = A_FUNC;
    argt_count = 0;
    rtlRtn = RTE_cmd_arg_cnt;
    hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), stb.user.dt_int);
    goto gen_call;

    /* cases where predeclared subroutines are called as functions */

  default:
    if ((pdsym = newsym(pdsym))) {
      SST_SYMP(stktop, pdsym);
      return mkvarref(stktop, list);
    }
    return fix_term(stktop, stb.i0);

  } /* End of switch */

  /* generate call where args stored in argpos */

gen_call:
  argt = mk_argt(argt_count + argt_extra); /* space for arguments */
  for (i = 0; i < argt_count; i++)
    ARGT_ARG(argt, i) = ARG_AST(i);
  for (; i < argt_count + argt_extra; i++)
    ARGT_ARG(argt, i) = 0;
  if (hpf_sym)
    func_ast = mk_id(hpf_sym);
  else
    func_ast = mk_id(pdsym);
  ast = mk_func_node(func_type, func_ast, argt_count + argt_extra, argt);
  if (shaper)
    dtyper = dtype_with_shape(dtyper, shaper);
  A_DTYPEP(ast, dtyper);
  A_DTYPEP(func_ast, dtyper);
  if (func_type == A_INTR)
    A_OPTYPEP(ast, INTASTG(pdsym));
  if (shaper == 0)
    shaper = mkshape(dtyper);

expr_val:
  /* dtyper, shaper, ast 'define' the result of the expression */
  A_SHAPEP(ast, shaper);
  EXPSTP(pdsym, 1); /* freeze predeclared */
  SST_IDP(stktop, S_EXPR);
  SST_DTYPEP(stktop, dtyper);
  SST_ASTP(stktop, ast);
  SST_SHAPEP(stktop, shaper);
  /* Fortran floor/ceiling take real arguments and return integer values.
   * But we want to use the same ILM/ILI as C/C++ (which return integral
   * values in real format), so as to have common optimization and
   * vectorization techniques and routines. Thus do an explicit convert here.
   */
  if(pdtype == PD_floor || pdtype == PD_ceiling)
    cngtyp(stktop, dtype2); /* dtype2 from PD_floor/PD_ceiling case above */
  return 1;

/*
 * result is a 32-bit constant value, but the result is any
 * integer kind.
 */
const_default_int_val:
  dtyper = stb.user.dt_int; /*return default integer*/
                            /*
                             *  FALL THRU !!!!
                             */
const_kind_int_val:
  ast = mk_cval(conval, dtyper);
  EXPSTP(pdsym, 1); /* freeze predeclared */
  SST_IDP(stktop, S_CONST);
  SST_DTYPEP(stktop, dtyper);
  SST_SHAPEP(stktop, 0);
  SST_ASTP(stktop, ast);
  if (DTY(dtyper) != TY_INT8)
    SST_CVALP(stktop, conval);
  else
    SST_CVALP(stktop, A_SPTRG(ast));
  return SST_CVALG(stktop);

const_isz_val:
  ast = mk_isz_cval(iszval, dtyper);
  EXPSTP(pdsym, 1);
  SST_IDP(stktop, S_CONST);
  SST_DTYPEP(stktop, dtyper);
  SST_ASTP(stktop, ast);
  SST_SHAPEP(stktop, 0);
  if (DTY(dtyper) == TY_INT)
    SST_CVALP(stktop, iszval);
  else
    SST_CVALP(stktop, A_SPTRG(ast));
  return iszval;
const_real_val:
  EXPSTP(pdsym, 1); /* freeze predeclared */
  SST_IDP(stktop, S_CONST);
  SST_DTYPEP(stktop, DT_REAL4);
  SST_CVALP(stktop, val[0]);
  SST_SHAPEP(stktop, 0);
  ast = mk_cval1(val[0], DT_REAL4);
  SST_ASTP(stktop, ast);
  sptr = A_SPTRG(ast);
  return val[0];

const_dble_val:
  tmp = getcon(val, DT_REAL8);
  EXPSTP(pdsym, 1); /* freeze predeclared */
  SST_IDP(stktop, S_CONST);
  SST_DTYPEP(stktop, DT_REAL8);
  SST_CVALP(stktop, tmp);
  SST_SHAPEP(stktop, 0);
  SST_ASTP(stktop, mk_cnst(tmp));
  return tmp;

const_dword_val:
  tmp = getcon(val, DT_DWORD);
  EXPSTP(pdsym, 1); /* freeze predeclared */
  SST_IDP(stktop, S_CONST);
  SST_DTYPEP(stktop, DT_DWORD);
  SST_CVALP(stktop, tmp);
  SST_SHAPEP(stktop, 0);
  SST_ASTP(stktop, mk_cnst(tmp));
  return tmp;

const_quad_val:
  tmp = getcon(val, DT_QUAD);
  EXPSTP(pdsym, 1); /* freeze predeclared */
  SST_IDP(stktop, S_CONST);
  SST_DTYPEP(stktop, DT_QUAD);
  SST_CVALP(stktop, tmp);
  SST_SHAPEP(stktop, 0);
  SST_ASTP(stktop, mk_cnst(tmp));
  return tmp;

const_str_val:
  EXPSTP(pdsym, 1); /* freeze predeclared */
  SST_IDP(stktop, S_CONST);
  SST_DTYPEP(stktop, DTYPEG(sptr));
  SST_CVALP(stktop, sptr);
  SST_SHAPEP(stktop, 0);
  SST_ASTP(stktop, mk_cnst(sptr));
  return sptr;

const_int_ast:
  val[0] = CONVAL2G(A_SPTRG(ast));
  EXPSTP(pdsym, 1); /* freeze predeclared */
  SST_IDP(stktop, S_CONST);
  SST_DTYPEP(stktop, DT_INT4);
  SST_CVALP(stktop, val[0]);
  SST_SHAPEP(stktop, 0);
  SST_ASTP(stktop, ast);
  return val[0];

const_int8_ast:
  tmp = A_SPTRG(ast);
  EXPSTP(pdsym, 1); /* freeze predeclared */
  SST_IDP(stktop, S_CONST);
  SST_DTYPEP(stktop, DT_INT8);
  SST_CVALP(stktop, tmp);
  SST_SHAPEP(stktop, 0);
  SST_ASTP(stktop, ast);
  return tmp;

const_real_ast:
  val[0] = CONVAL2G(A_SPTRG(ast));
  EXPSTP(pdsym, 1); /* freeze predeclared */
  SST_IDP(stktop, S_CONST);
  SST_DTYPEP(stktop, DT_REAL4);
  SST_CVALP(stktop, val[0]);
  SST_SHAPEP(stktop, 0);
  SST_ASTP(stktop, ast);
  return val[0];

const_dble_ast:
  tmp = A_SPTRG(ast);
  EXPSTP(pdsym, 1); /* freeze predeclared */
  SST_IDP(stktop, S_CONST);
  SST_DTYPEP(stktop, DT_REAL8);
  SST_CVALP(stktop, tmp);
  SST_SHAPEP(stktop, 0);
  SST_ASTP(stktop, ast);
  return tmp;

const_quad_ast:
  tmp = A_SPTRG(ast);
  EXPSTP(pdsym, 1); /* freeze predeclared */
  SST_IDP(stktop, S_CONST);
  SST_DTYPEP(stktop, DT_QUAD);
  SST_CVALP(stktop, tmp);
  SST_SHAPEP(stktop, 0);
  SST_ASTP(stktop, ast);
  return tmp;

bad_args:
  if (EXPSTG(pdsym)) {
    /* Intrinsic frozen, therefore user misused intrinsic */
    error(74, 3, gbl.lineno, SYMNAME(pdsym), CNULL);
    return (fix_term(stktop, stb.i0));
  }
  /* Intrinsic not frozen, try to interpret as a function call */
  SST_SYMP(stktop, newsym(pdsym));
  return (mkvarref(stktop, list));

call_e74_cnt:
  e74_cnt(_e74_sym, _e74_cnt, _e74_l, _e74_u);
  goto exit_;
call_e74_arg:
  e74_arg(_e74_sym, _e74_pos, _e74_kwd);
exit_:
  dont_issue_assumedsize_error = 0;
  EXPSTP(pdsym, 1); /* freeze predeclared */
  SST_IDP(stktop, S_EXPR);
  SST_DTYPEP(stktop, DT_INT);
  SST_ASTP(stktop, astb.i0);
  SST_SHAPEP(stktop, 0);
  return 1;
ill_call:
  error(84, 3, gbl.lineno, SYMNAME(pdsym),
        "- attempt to use a subroutine intrinsic as a function");
  return (fix_term(stktop, stb.i0));
}

static int
getMergeSym(int dt, int ikind)
{
  int sym;
  FtnRtlEnum rtlRtn;
  int localDt = dt;

  switch (DTY(dt)) {
  case TY_BINT:
    rtlRtn = RTE_mergei1;
    break;
  case TY_SINT:
    rtlRtn = RTE_mergei2;
    break;
  case TY_INT:
    rtlRtn = RTE_mergei;
    break;
  case TY_INT8:
    rtlRtn = RTE_mergei8;
    break;
  case TY_REAL:
    rtlRtn = RTE_merger;
    break;
  case TY_DBLE:
    rtlRtn = RTE_merged;
    break;
  case TY_QUAD:
    rtlRtn = RTE_mergeq;
    break;
  case TY_CMPLX:
    rtlRtn = RTE_mergec;
    break;
  case TY_DCMPLX:
    rtlRtn = RTE_mergedc;
    break;
  case TY_BLOG:
    rtlRtn = RTE_mergel1;
    break;
  case TY_SLOG:
    rtlRtn = RTE_mergel2;
    break;
  case TY_LOG:
    rtlRtn = RTE_mergel;
    break;
  case TY_LOG8:
    rtlRtn = RTE_mergel8;
    break;
  case TY_CHAR:
    rtlRtn = RTE_mergecha;
    localDt = DT_NONE;
    break;
  case TY_DERIVED:
    rtlRtn = RTE_mergedt;
    localDt = DT_NONE;
    break;
  default:
    interr("getMergeSym:unexp.dt", DTY(dt), 3);
    break;
  }
  sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), localDt);
  INKINDP(sym, ikind);
  return sym;
}

static void
ref_pd_subr(SST *stktop, ITEM *list)
{
  int extsym, count, pdsym, dtype;
  int sptr, sptr2;
  int dtype1, dtype2;
  int shape, shape1;
  int i, dum;
  ITEM *ip1;
  int ast, lop;
  int argt;
  int argt_count;
  SST *sp;
  SST *stkp;
  int is_real2_arg_error = 0;

  /* Count the number of arguments to function */
  count = 0;
  pdsym = SST_SYMG(stktop);
  for (ip1 = list; ip1 != ITEM_END; ip1 = ip1->next) {
    count++;
  }

  argt_count = count;
  switch (PDNUMG(pdsym)) {
  case PD_exit:
    if (count > 1 || (count == 1 && evl_kwd_args(list, 1, KWDARGSTR(pdsym))))
      goto bad_args;
    EXPSTP(pdsym, 1); /* freeze predeclared */
    ast =
        begin_call(A_CALL, sym_mkfunc_nodesc(mkRteRtnNm(RTE_exit), DT_NONE), 1);
    if (count == 0)
      add_arg(astb.i0);
    else
      add_arg(ARG_AST(0));
    SST_ASTP(stktop, ast);
    return;

  case PD_date:
    if (count != 1 || get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto bad_args;
    goto time_shared;
  case PD_time:
    if (count != 1 || get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto bad_args;
  time_shared:
    if (!is_varref(ARG_STK(0)))
      goto bad_args;
    (void)mkarg(ARG_STK(0), &dum);
    XFR_ARGAST(0);
    break;

  case PD_idate:
    if (count != 3 || get_kwd_args(list, 3, KWDARGSTR(pdsym)))
      goto bad_args;
    dtype = SST_DTYPEG(ARG_STK(0));
    if ((dtype != DT_INT && dtype != DT_SINT) || !is_varref(ARG_STK(0)))
      goto bad_args;
    (void)mkarg(ARG_STK(0), &dum);
    XFR_ARGAST(0);
    for (i = 1; i <= 2; i++) {
      if (SST_DTYPEG(ARG_STK(i)) != dtype || !is_varref(ARG_STK(i)))
        goto bad_args;
      (void)mkarg(ARG_STK(i), &dum);
      XFR_ARGAST(i);
    }
    break;

  case PD_move_alloc:
    if (count != 2) {
      E74_CNT(pdsym, count, 2, 2);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 2, KWDARGSTR(pdsym)))
      goto exit_;
    sp = ARG_STK(0);
    if (!is_varref(sp)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    (void)mkarg(sp, &dum);
    XFR_ARGAST(0);
    sptr = memsym_of_ast(ARG_AST(0));
    if (!ALLOCATTRG(sptr)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }

    sp = ARG_STK(1);
    if (!is_varref(sp)) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    (void)mkarg(sp, &dum);
    XFR_ARGAST(1);
    sptr2 = memsym_of_ast(ARG_AST(1));
    if (!ALLOCATTRG(sptr2)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if (CLASSG(sptr) && !CLASSG(sptr2)) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    NOALLOOPTP(sptr2, 1);
    dtype1 = A_DTYPEG(ARG_AST(0));
    dtype2 = A_DTYPEG(ARG_AST(1));
    if (rank_of(dtype1) != rank_of(dtype2)) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    dtype1 = DDTG(dtype1);
    dtype2 = DDTG(dtype2);
    /*
     * type compatible here means character of any length?
     */
    if (DTY(dtype1) == TY_CHAR && DTY(dtype2) == TY_CHAR)
      break;
    if (DTY(dtype1) == TY_NCHAR && DTY(dtype2) == TY_NCHAR)
      break;
    if (!eq_dtype2(dtype2, dtype1, CLASSG(sptr2))) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    break;

  case PD_mvbits:
    /* call mvbits(from, frompos, len, to, topos) */
    if (count != 5) {
      E74_CNT(pdsym, count, 5, 5);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 5, KWDARGSTR(pdsym)))
      goto exit_;

    for (i = 0; i <= 4; i++) {
      dtype = DDTG(SST_DTYPEG(ARG_STK(i)));
      if (!DT_ISINT(dtype)) {
        E74_ARG(pdsym, i, NULL);
        goto call_e74_arg;
      }
    }

    sp = ARG_STK(0); /* from */
    dtype = DDTG(SST_DTYPEG(sp));

    sp = ARG_STK(3); /* to */
    if (!is_varref(sp)) {
      E74_ARG(pdsym, 3, NULL);
      goto call_e74_arg;
    }
    dtype1 = DDTG(SST_DTYPEG(sp));
    if (dtype != dtype1) {
      E74_ARG(pdsym, 3, NULL);
      goto call_e74_arg;
    }
    (void)mkarg(sp, &dum);
    XFR_ARGAST(3);
    shape = SST_SHAPEG(sp);

    for (i = 0; i <= 4; i++) {
      sp = ARG_STK(i);
      (void)mkexpr(sp);
      XFR_ARGAST(i);
      shape1 = SST_SHAPEG(sp);
      if (shape) {
        if (shape1 && !conform_shape(shape, shape1)) {
          E74_ARG(pdsym, i, NULL);
          goto call_e74_arg;
        }
      } else
        shape = shape1;
    }
    break;

  case PD_date_and_time:
    if (count > 4) {
      E74_CNT(pdsym, count, 0, 4);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 4, KWDARGSTR(pdsym)))
      goto exit_;
    argt_count = 4;
    for (i = 0; i <= 2; i++) /* date, time, zone */
      if ((sp = ARG_STK(i))) {
        if (!is_varref(sp) || DTY(SST_DTYPEG(sp)) != TY_CHAR) {
          E74_ARG(pdsym, i, NULL);
          goto call_e74_arg;
        }
        (void)mkarg(sp, &dum);
        XFR_ARGAST(i);
      } else
        ARG_AST(i) = astb.ptr0c;
    if ((sp = ARG_STK(3))) { /* values */
      if (!is_varref(sp)) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(sp, &dum);
      XFR_ARGAST(3);
      dtype = SST_DTYPEG(sp);
      if (!DT_ISINT_ARR(dtype) || rank_of_ast(ARG_AST(3)) != 1) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
    }
    break;

  case PD_cpu_time:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    if ((sp = ARG_STK(0))) {
      if (!is_varref(sp)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
      dtype = SST_DTYPEG(sp);
      if (!DT_ISREAL(dtype)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(sp, &dum);
      XFR_ARGAST(0);
    }
    break;

  case PD_random_number:
    if (count != 1) {
      E74_CNT(pdsym, count, 1, 1);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    if ((sp = ARG_STK(0))) {
      if (!is_varref(sp)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
      dtype = SST_DTYPEG(sp);
      if (!DT_ISREAL(DDTG(dtype))) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(sp, &dum);
      XFR_ARGAST(0);
      sptr = sym_of_ast(ARG_AST(0)); /* the HARVEST arg */
      ADDRTKNP(sptr, 1);
    }
    break;
  case PD_random_seed:
    if (count > 3) {
      E74_CNT(pdsym, count, 0, 3);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 3, KWDARGSTR(pdsym)))
      goto exit_;
    argt_count = 3;
    for (i = 1; i <= 2; i++)
      if ((sp = ARG_STK(i))) {
        if (i == 2 && !is_varref(sp)) {
          /* get argument must be variable */
          E74_ARG(pdsym, i, NULL);
          goto call_e74_arg;
        }
        dtype = SST_DTYPEG(sp);
        (void)mkarg(sp, &dum);
        XFR_ARGAST(i);
        if (!DT_ISINT_ARR(dtype) || rank_of_ast(ARG_AST(i)) != 1) {
          E74_ARG(pdsym, i, NULL);
          goto call_e74_arg;
        }
        if (i == 2) {
          sptr = sym_of_ast(ARG_AST(2)); /* intent OUT arg */
          ADDRTKNP(sptr, 1);
        }
      }
    if ((sp = ARG_STK(0))) {
      if (!is_varref(sp)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
      dtype = SST_DTYPEG(sp);
      if (!DT_ISINT(dtype)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(sp, &dum);
      XFR_ARGAST(0);
      sptr = sym_of_ast(ARG_AST(0)); /* intent OUT arg */
      ADDRTKNP(sptr, 1);
    }
    break;
  case PD_system_clock:
    if (count > 3) {
      E74_CNT(pdsym, count, 0, 3);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 3, KWDARGSTR(pdsym)))
      goto exit_;
    argt_count = 3;
    for (i = 0; i <= 2; i++)
      if ((sp = ARG_STK(i))) {
        if (!is_varref(sp)) {
          E74_ARG(pdsym, i, NULL);
          goto call_e74_arg;
        }
        dtype = SST_DTYPEG(sp);
        if (!DT_ISINT(dtype)) {
          /* f2003 allows count_rate to be integer or real */
          if (i != 1 || !DT_ISREAL(dtype)) {
            E74_ARG(pdsym, i, NULL);
            goto call_e74_arg;
          }
        }
        (void)mkarg(sp, &dum);
        XFR_ARGAST(i);
      }
    break;

  case PD_ranget:
    if (count > 1) {
      E74_CNT(pdsym, count, 0, 1);
      goto call_e74_cnt;
    }
    if (REFG(pdsym) && FUNCG(pdsym))
      goto ill_call; /* can be CALL'd, but must be consistent */
    if (get_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    if ((stkp = ARG_STK(0))) { /* i */
      if (!is_varref(stkp)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(stkp, &dum);
      XFR_ARGAST(0);
      dtype2 = SST_DTYPEG(stkp);
      if (dtype2 != DT_INT) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
    }
    REFP(pdsym, 1);
    break;
  case PD_ranset:
    if (count > 1) {
      E74_CNT(pdsym, count, 0, 1);
      goto call_e74_cnt;
    }
    if (REFG(pdsym) && FUNCG(pdsym))
      goto ill_call; /* can be CALL'd, but must be consistent */
    if (evl_kwd_args(list, 1, KWDARGSTR(pdsym)))
      goto exit_;
    if ((stkp = ARG_STK(0))) { /* i */
      (void)mkarg(stkp, &dum);
      XFR_ARGAST(0);
      dtype2 = SST_DTYPEG(stkp);
      if (!DT_ISINT(dtype2) && dtype2 != DT_REAL) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
    }
    REFP(pdsym, 1);
    break;

  case PD_get_command_argument:
    if (count < 1 || count > 4) {
      E74_CNT(pdsym, count, 1, 4);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 4, KWDARGSTR(pdsym)))
      goto exit_;
    sp = ARG_STK(0); /* number */
    (void)mkexpr(sp);
    XFR_ARGAST(0);
    dtype2 = SST_DTYPEG(sp);
    if (dtype2 != stb.user.dt_int) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if ((sp = ARG_STK(1))) { /* value */
      if (!is_varref(sp)) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(sp, &dum);
      XFR_ARGAST(1);
      dtype2 = SST_DTYPEG(sp);
      if (DTY(dtype2) != TY_CHAR) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    }
    if ((sp = ARG_STK(2))) { /* length */
      if (!is_varref(sp)) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(sp, &dum);
      XFR_ARGAST(2);
      dtype2 = SST_DTYPEG(sp);
      if (dtype2 != stb.user.dt_int) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
    }
    if ((sp = ARG_STK(3))) { /* status */
      if (!is_varref(sp)) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(sp, &dum);
      XFR_ARGAST(3);
      dtype2 = SST_DTYPEG(sp);
      if (dtype2 != stb.user.dt_int) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
    }
    argt_count = 4;
    break;

  case PD_get_command:
    if (count > 3) {
      E74_CNT(pdsym, count, 0, 3);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 3, KWDARGSTR(pdsym)))
      goto exit_;
    if ((sp = ARG_STK(0))) { /* command */
      if (!is_varref(sp)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(sp, &dum);
      XFR_ARGAST(0);
      dtype2 = SST_DTYPEG(sp);
      if (DTY(dtype2) != TY_CHAR) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
    }
    if ((sp = ARG_STK(1))) { /* length */
      if (!is_varref(sp)) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(sp, &dum);
      XFR_ARGAST(1);
      dtype2 = SST_DTYPEG(sp);
      if (dtype2 != stb.user.dt_int) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    }
    if ((sp = ARG_STK(2))) { /* status */
      if (!is_varref(sp)) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(sp, &dum);
      XFR_ARGAST(2);
      dtype2 = SST_DTYPEG(sp);
      if (dtype2 != stb.user.dt_int) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
    }
    argt_count = 3;
    break;

  case PD_get_environment_variable:
    if (count < 1 || count > 5) {
      E74_CNT(pdsym, count, 1, 5);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, 5, KWDARGSTR(pdsym)))
      goto exit_;
    sp = ARG_STK(0); /* name */
    (void)mkexpr(sp);
    XFR_ARGAST(0);
    dtype2 = SST_DTYPEG(sp);
    if (DTY(dtype2) != TY_CHAR) {
      E74_ARG(pdsym, 0, NULL);
      goto call_e74_arg;
    }
    if ((sp = ARG_STK(1))) { /* value */
      if (!is_varref(sp)) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(sp, &dum);
      XFR_ARGAST(1);
      dtype2 = SST_DTYPEG(sp);
      if (DTY(dtype2) != TY_CHAR) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
    }
    if ((sp = ARG_STK(2))) { /* length */
      if (!is_varref(sp)) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(sp, &dum);
      XFR_ARGAST(2);
      dtype2 = SST_DTYPEG(sp);
      if (dtype2 != stb.user.dt_int) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
    }
    if ((sp = ARG_STK(3))) { /* status */
      if (!is_varref(sp)) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(sp, &dum);
      XFR_ARGAST(3);
      dtype2 = SST_DTYPEG(sp);
      if (dtype2 != stb.user.dt_int) {
        E74_ARG(pdsym, 3, NULL);
        goto call_e74_arg;
      }
    }
    if ((sp = ARG_STK(4))) { /* trim_name */
      (void)mkexpr(sp);
      XFR_ARGAST(4);
      dtype2 = SST_DTYPEG(sp);
      if (dtype2 != stb.user.dt_log) {
        E74_ARG(pdsym, 4, NULL);
        goto call_e74_arg;
      }
    }
    argt_count = 5;
    break;

    /* cases where predeclared functions are CALL'd */

  default:
    if ((pdsym = newsym(pdsym))) {
      SST_SYMP(stktop, pdsym);
      subr_call(stktop, list);
    }
    return;

  } /* End of switch */

  /*  generate call */

  EXPSTP(pdsym, 1);           /* freeze predeclared */
  argt = mk_argt(argt_count); /* space for arguments */
  for (i = 0; i < argt_count; i++)
    ARGT_ARG(argt, i) = ARG_AST(i);
  ast = mk_stmt(A_ICALL, 0);
  lop = mk_id(pdsym);
  A_LOPP(ast, lop);
  A_OPTYPEP(ast, INTASTG(pdsym));
  A_ARGCNTP(ast, argt_count);
  A_ARGSP(ast, argt);
  SST_ASTP(stktop, ast);
  return;

bad_args:
  /*  if a non-stanrard intrinsic, attempt to override intrinsic property */
  if (EXPSTG(pdsym)) {
    error(74, 3, gbl.lineno, SYMNAME(pdsym), CNULL);
  } else {
    /* Intrinsic not frozen, interpret as a subroutine call */
    SST_SYMP(stktop, newsym(pdsym));
    subr_call(stktop, list);
  }
  return;
call_e74_cnt:
  e74_cnt(_e74_sym, _e74_cnt, _e74_l, _e74_u);
  goto exit_;
call_e74_arg:
  e74_arg(_e74_sym, _e74_pos, _e74_kwd);
exit_:
  return;
ill_call:
  error(84, 3, gbl.lineno, SYMNAME(pdsym),
        "- attempt to CALL a function intrinsic");
}

static void
ref_intrin_subr(SST *stktop, ITEM *list)
{
  int extsym, count, pdsym, dtype;
  int sptr;
  int dtype1, dtype2;
  int shape, shape1;
  int i, dum;
  ITEM *ip1;
  int ast, lop;
  int argt;
  int argt_count;
  SST *sp;
  SST *stkp;

  /* Count the number of arguments to function */
  count = 0;
  pdsym = SST_SYMG(stktop);
  for (ip1 = list; ip1 != ITEM_END; ip1 = ip1->next) {
    count++;
  }

  argt_count = count;
  switch (INTASTG(pdsym)) {
  case I_C_F_POINTER:
    if (count < 2 || count > 3) {
      E74_CNT(pdsym, count, 1, 3);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, count, KWDARGSTR(pdsym)))
      goto bad_args;
    sp = ARG_STK(0); /* CPTR */
    (void)mkarg(sp, &dum);
    XFR_ARGAST(0);
    dtype2 = SST_DTYPEG(sp);
    if (!is_iso_c_loc(ARG_AST(0))) {
      if (!is_iso_c_ptr(dtype2)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
    }
    sp = ARG_STK(1); /* fptr */
    if (!is_varref(sp)) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    (void)mkarg(sp, &dum);
    XFR_ARGAST(1);
    sptr = find_pointer_variable(ARG_AST(1));
    if (!sptr || !POINTERG(sptr)) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
  cfptr_shp:
    if ((sp = ARG_STK(2))) { /* shape */
      if (DTY(SST_DTYPEG(ARG_STK(1))) != TY_ARRAY) {
        E74_ARG(pdsym, 1, NULL);
        goto call_e74_arg;
      }
      (void)mkarg(sp, &dum);
      XFR_ARGAST(2);
      dtype2 = SST_DTYPEG(sp);
      if (DTY(dtype2) != TY_ARRAY || !DT_ISINT(DTY(dtype2 + 1))) {
        E74_ARG(pdsym, 2, NULL);
        goto call_e74_arg;
      }
    } else if (DTY(SST_DTYPEG(ARG_STK(1))) == TY_ARRAY) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    break;
  case I_C_F_PROCPOINTER:
    if (count != 2) {
      E74_CNT(pdsym, count, 2, 2);
      goto call_e74_cnt;
    }
    if (get_kwd_args(list, count, KWDARGSTR(pdsym)))
      goto bad_args;
    sp = ARG_STK(0); /* CPTR */
    (void)mkarg(sp, &dum);
    XFR_ARGAST(0);
    dtype2 = SST_DTYPEG(sp);
    if (!is_iso_c_funloc(ARG_AST(0))) {
      if (!is_iso_c_funptr(dtype2)) {
        E74_ARG(pdsym, 0, NULL);
        goto call_e74_arg;
      }
    }
    sp = ARG_STK(1); /* fptr */
    if (!is_varref(sp)) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    (void)mkarg(sp, &dum);
    XFR_ARGAST(1);
    sptr = find_pointer_variable(ARG_AST(1));
    if (!sptr || !is_procedure_ptr(sptr)) {
      E74_ARG(pdsym, 1, NULL);
      goto call_e74_arg;
    }
    break;
  /* cases where predeclared functions are CALL'd */
  default:
    if ((pdsym = newsym(pdsym))) {
      SST_SYMP(stktop, pdsym);
      subr_call(stktop, list);
    }
    return;

  } /* End of switch */

  /*  generate call */

  EXPSTP(pdsym, 1);           /* freeze predeclared */
  argt = mk_argt(argt_count); /* space for arguments */
  for (i = 0; i < argt_count; i++)
    ARGT_ARG(argt, i) = ARG_AST(i);
  ast = mk_stmt(A_ICALL, 0);
  lop = mk_id(pdsym);
  A_LOPP(ast, lop);
  A_OPTYPEP(ast, INTASTG(pdsym));
  A_ARGCNTP(ast, argt_count);
  A_ARGSP(ast, argt);
  SST_ASTP(stktop, ast);
  return;

bad_args:
  /*  if a non-stanrard intrinsic, attempt to override intrinsic property */
  if (EXPSTG(pdsym)) {
    error(74, 3, gbl.lineno, SYMNAME(pdsym), CNULL);
  } else {
    /* Intrinsic not frozen, interpret as a subroutine call */
    SST_SYMP(stktop, newsym(pdsym));
    subr_call(stktop, list);
  }
  return;
call_e74_cnt:
  e74_cnt(_e74_sym, _e74_cnt, _e74_l, _e74_u);
  goto exit_;
call_e74_arg:
  e74_arg(_e74_sym, _e74_pos, _e74_kwd);
exit_:
  return;
ill_call:
  error(84, 3, gbl.lineno, SYMNAME(pdsym),
        "- attempt to CALL a function intrinsic");
}

/*
 * Compare the two shapes and check for conformance.  Return:
 * 1.  if one shape is scalar and the other is array, return the shape
 *     of the array;
 * 2.  if both are arrays and are not conformant, return -1 (error);
 * 3.  otherwise, return the first shape.
 */
static int
set_shape_result(int shape1, int shape2)
{
  if (shape1) {
    if (shape2 && !conform_shape(shape1, shape2))
      return -1;
  } else if (shape2)
    return shape2;

  return shape1;
}

/*
 * a kind argument is present in an intrinsic and is used to select
 * the result of the intrinsic
 */
static int
set_kind_result(SST *stkp, int dt, int ty)
{
  int kind;
  int dtype2;

  dtype2 = SST_DTYPEG(stkp);
  if (!DT_ISINT(dtype2))
    return 0; /* ERROR */
  if (is_sst_const(stkp))
    kind = cngcon(get_sst_cval(stkp), dtype2, DT_INT4);
  else if (SST_IDG(stkp) == S_EXPR) {
    int ast;
    ast = SST_ASTG(stkp);
    if (A_ALIASG(ast))
      kind = get_int_cval(A_SPTRG(ast));
    else
      return 0;
  } else {
    return 0; /* ERROR */
  }
  dtype2 = select_kind(dt, ty, kind);
  return dtype2;
}

static int
mk_array_type(int arr_spec_dt, int base_dtype)
{
  int rdtype;
  int rank;
  ADSC *ad;
  int ubound;
  int lbound;
  int i;

  ad = AD_DPTR(arr_spec_dt);
  rank = AD_NUMDIM(ad);

  sem.arrdim.ndim = rank;
  sem.arrdim.ndefer = 0;
  for (i = 0; i < rank; i++) {
    ubound = AD_UPAST(ad, i);
    lbound = AD_LWAST(ad, i);
    if (A_TYPEG(ubound) != A_CNST || A_TYPEG(lbound) != A_CNST) {
      error(87, 3, gbl.lineno, NULL, NULL);
      sem.dinit_error = TRUE;
      return 0;
    }

    sem.bounds[i].lowtype = S_CONST;
    sem.bounds[i].lowb = get_int_cval(A_SPTRG(lbound));
    sem.bounds[i].lwast = 0;
    sem.bounds[i].uptype = S_CONST;
    sem.bounds[i].upb = get_int_cval(A_SPTRG(ubound));
    sem.bounds[i].upast = ubound;
  }
  rdtype = mk_arrdsc();
  DTY(rdtype + 1) = base_dtype;

  return rdtype;
}

static int
_adjustl(int string)
{
  char *p, *cp, *str;
  char ch;
  int i, cvlen, origlen, result;
  int dtyper, dtype;
  INT val[2];

  dtyper = dtype = DTYPEG(string);
  if (DTY(dtyper) == TY_NCHAR) {
    string = CONVAL1G(string);
    dtype = DTYPEG(string);
  }
  p = stb.n_base + CONVAL1G(string);
  cvlen = string_length(dtype);
  origlen = cvlen;
  str = cp = getitem(0, cvlen + 1); /* +1 just in case cvlen is 0 */
  i = 0;
  /* left justify string - skip leading blanks */
  while (cvlen-- > 0) {
    ch = *p++;
    if (ch != ' ') {
      *cp++ = ch;
      break;
    }
    i++;
  }
  while (cvlen-- > 0)
    *cp++ = *p++;
  /* append blanks */
  while (i-- > 0)
    *cp++ = ' ';
  result = getstring(str, origlen);
  if (DTY(dtyper) == TY_NCHAR) {
    val[0] = result;
    val[1] = 0;
    result = getcon(val, dtyper);
  }
  return result;
}

static int
_adjustr(int string)
{
  char *p, *cp, *str;
  char ch;
  int i, cvlen, origlen, result;
  int dtyper, dtype;
  INT val[2];

  dtyper = dtype = DTYPEG(string);
  if (DTY(dtyper) == TY_NCHAR) {
    string = CONVAL1G(string);
    dtype = DTYPEG(string);
  }
  p = stb.n_base + CONVAL1G(string);
  origlen = cvlen = string_length(dtype);
  str = cp = getitem(0, cvlen + 1); /* +1 just in case cvlen is 0 */
  i = 0;
  p += cvlen - 1;
  cp += cvlen - 1;
  /* right justify string - skip trailing blanks */
  while (cvlen-- > 0) {
    ch = *p--;
    if (ch != ' ') {
      *cp-- = ch;
      break;
    }
    i++;
  }
  while (cvlen-- > 0)
    *cp-- = *p--;
  /* insert blanks */
  while (i-- > 0)
    *cp-- = ' ';
  result = getstring(str, origlen);
  if (DTY(dtyper) == TY_NCHAR) {
    val[0] = result;
    val[1] = 0;
    result = getcon(val, dtyper);
  }
  return result;
}

static int
_index(int string, int substring, int back)
{
  int i, n;
  int l_string, l_substring;
  char *p_string, *p_substring;

  p_string = stb.n_base + CONVAL1G(string);
  l_string = string_length(DTYPEG(string));
  p_substring = stb.n_base + CONVAL1G(substring);
  l_substring = string_length(DTYPEG(substring));
  n = l_string - l_substring;
  if (n < 0)
    return 0;
  if (get_int_cval(back) == 0) {
    if (l_substring == 0)
      return 1;
    for (i = 0; i <= n; ++i) {
      if (p_string[i] == p_substring[0] &&
          strncmp(p_string + i, p_substring, l_substring) == 0)
        return i + 1;
    }
  } else {
    if (l_substring == 0)
      return l_string + 1;
    for (i = n; i >= 0; --i) {
      if (p_string[i] == p_substring[0] &&
          strncmp(p_string + i, p_substring, l_substring) == 0)
        return i + 1;
    }
  }
  return 0;
}

static int
_len_trim(int string)
{
  char *p;
  int i, cvlen, result;
  int dtype;

  dtype = DTYPEG(string);
  if (DTY(dtype) == TY_NCHAR) {
    string = CONVAL1G(string);
    dtype = DTYPEG(string);
  }
  p = stb.n_base + CONVAL1G(string);
  result = cvlen = string_length(dtype);
  i = 0;
  p += cvlen - 1;
  /* skip trailing blanks */
  while (cvlen-- > 0) {
    if (*p-- != ' ')
      break;
    result--;
  }
  return result;
}

static int
_repeat(int string, int ncopies)
{
  char *p, *cp, *str;
  char ch;
  int i, j, cvlen, newlen, result;
  int dtyper, dtype;
  INT val[2];

  ncopies = get_int_cval(ncopies);
  dtyper = dtype = DTYPEG(string);
  if (DTY(dtyper) == TY_NCHAR) {
    string = CONVAL1G(string);
    dtype = DTYPEG(string);
  }
  cvlen = string_length(dtype);
  newlen = cvlen * ncopies;
  if (newlen == 0) {
    str = "";
    result = getstring(str, strlen(str));
    if (DTY(dtyper) == TY_NCHAR) {
      dtype = get_type(2, TY_NCHAR, strlen(str));
      val[0] = result;
      val[1] = 0;
      result = getcon(val, dtype);
    }
    return result;
  }
  str = cp = getitem(0, newlen);
  j = ncopies;
  while (j-- > 0) {
    p = stb.n_base + CONVAL1G(string);
    i = cvlen;
    while (i-- > 0)
      *cp++ = *p++;
  }
  result = getstring(str, newlen);
  if (DTY(dtyper) == TY_NCHAR) {
    val[0] = result;
    val[1] = 0;
    dtyper = get_type(2, TY_NCHAR,
                      mk_cval(ncopies * string_length(dtyper), DT_INT4));
    result = getcon(val, dtyper);
  }
  return result;
}

static int
_scan(int string, int set, int back)
{
  int i, j;
  int l_string, l_set;
  char *p_string, *p_set;

  p_string = stb.n_base + CONVAL1G(string);
  l_string = string_length(DTYPEG(string));
  p_set = stb.n_base + CONVAL1G(set);
  l_set = string_length(DTYPEG(set));
  if (get_int_cval(back) == 0) {
    for (i = 0; i < l_string; ++i)
      for (j = 0; j < l_set; ++j)
        if (p_set[j] == p_string[i])
          return i + 1;
  } else {
    for (i = l_string - 1; i >= 0; --i)
      for (j = 0; j < l_set; ++j)
        if (p_set[j] == p_string[i])
          return i + 1;
  }
  return 0;
}

static int
_trim(int string)
{
  char *p, *cp, *str;
  int i, cvlen, newlen, result;
  int dtyper, dtype;
  INT val[2];

  dtyper = dtype = DTYPEG(string);
  if (DTY(dtyper) == TY_NCHAR) {
    string = CONVAL1G(string);
    dtype = DTYPEG(string);
  }
  p = stb.n_base + CONVAL1G(string);
  newlen = cvlen = string_length(dtype);
  i = 0;
  p += cvlen - 1;
  /* skip trailing blanks */
  while (cvlen-- > 0) {
    if (*p-- != ' ')
      break;
    newlen--;
  }
  if (newlen == 0) {
    str = "";
    result = getstring(str, strlen(str));
    if (DTY(dtyper) == TY_NCHAR) {
      dtype = get_type(2, TY_NCHAR, strlen(str));
      val[0] = result;
      val[1] = 0;
      result = getcon(val, dtype);
    }
    return result;
  }
  str = cp = getitem(0, newlen);
  i = newlen;
  cp += newlen - 1;
  p++;
  while (i-- > 0) {
    *cp-- = *p--;
  }
  result = getstring(str, newlen);
  if (DTY(dtyper) == TY_NCHAR) {
    i = kanji_len((unsigned char *)str, newlen);
    dtype = get_type(2, TY_NCHAR, i);
    val[0] = result;
    val[1] = 0;
    result = getcon(val, dtype);
  }
  return result;
}

static int
_verify(int string, int set, int back)
{
  int i, j;
  int l_string, l_set;
  char *p_string, *p_set;

  p_string = stb.n_base + CONVAL1G(string);
  l_string = string_length(DTYPEG(string));
  p_set = stb.n_base + CONVAL1G(set);
  l_set = string_length(DTYPEG(set));
  if (get_int_cval(back) == 0) {
    for (i = 0; i < l_string; ++i) {
      for (j = 0; j < l_set; ++j)
        if (p_set[j] == p_string[i])
          goto contf;
      return i + 1;
    contf:;
    }
  } else {
    for (i = l_string - 1; i >= 0; --i) {
      for (j = 0; j < l_set; ++j)
        if (p_set[j] == p_string[i])
          goto contb;
      return i + 1;
    contb:;
    }
  }
  return 0;
}

/** \brief Check charset
 *
 * Make sure this routine is consistent with
 * - f90:         dinit.c:_selected_char_kind()
 * - runtime/f90: miscsup_com.c:_selected_char_kind()
 */
int
_selected_char_kind(int con)
{
  if (sem_eq_str(con, "ASCII"))
    return 1;
  else if (sem_eq_str(con, "DEFAULT"))
    return 1;
  return -1;
}

/*if astdim is constant and out of range, give error messages */
static void
check_dim_error(int shape, int astdim)
{
  int dim;
  int ndim;

  /* dim is a constant */
  if (A_ALIASG(astdim)) {
    ndim = 0;
    if (shape)
      ndim = SHD_NDIM(shape);
    dim = get_int_cval(A_SPTRG(A_ALIASG(astdim)));
    if (dim < 1 || dim > ndim) {
      error(423, 3, gbl.lineno, NULL, NULL);
    }
  }
}