/**************************************************************************/
/*                                                                        */
/*                                 Sources                                */
/*                                from  the                               */
/*                           XSC SOFTWARE PACKAGE                         */
/*                                                                        */
/*                Copyright (c) 1997 University of Karlsruhe              */
/*                     Institute for Appl. Mathematics                    */
/*                                                                        */
/* This program is free software for non-commercial use. For details, see */
/* the file LICENSE.XSC, distributed with this software package.          */
/*                                                                        */
/* This program is distributed WITHOUT ANY WARRANTY. For details, see the */
/* file LICENSE.XSC, distributed with this software package.              */
/*                                                                        */
/**************************************************************************/

/* RCS $Id: y_suba.c,v 1.2 1997/09/25 18:26:35 ae59 Exp $ */
/*
$Log: y_suba.c,v $
 * Revision 1.2  1997/09/25  18:26:35  ae59
 * Copyright-message
 *
 * Revision 1.1  1994/01/27  13:25:58  ae59
 * Put under RCS control
 *
 */
/****************************************************************/
/*                                                              */
/*      Filename        : y_suba.c                              */
/*                                                              */
/*      Entry           : a_VOID y_suba(m,s,mode,e_args)        */
/*                        a_VOID m;                             */
/*                        a_VOID s;                             */
/*                        a_char *mode;                         */
/*                        e_list                                */
/*                                                              */
/*      Arguments       : m - descriptor of main array          */
/*                        s - descriptor of subarray            */
/*                        mode - subarray mode                  */
/*                           "0" - index range of main array    */
/*                           "1" - constant index               */
/*                           "2" - index range from arg. list   */
/*                           "3" - lbound from arg. list        */
/*                           "4" - ubound from arg. list        */
/*                                                              */
/*                        e_args - variable argument list       */
/*                                                              */
/*      Note            : subarrays are never temporary         */
/*                                                              */
/*      Description     : generation of a subarray descriptor   */
/*                                                              */
/*      Date            : 1993-11-23                            */
/*      1993-11-23 : cas 1: index have to a_intg        =b=     */
/*      1993-11-02 : documentation on allocation chek m =b=     */
/*      1993-08-30 : index check in case '1'            =b=     */
/*      1993-02-12 : corrected arguments for INDEX error=b=     */
/*      1993-01-19 : check m being allocated            =b=     */
/*      1992-11-30 : check index when taken from argline=b=     */
/*      1992-07-22 : cast to a_byte and char* at strlen =b=     */
/*                   cast to size_t at elnum asignment          */
/*      1992-02-26 : change argument types y_dscp to a_VOID     */
/*      1992-02-07 : change return (char*) to a_VOID =b         */
/*      1992-01-01 : sdim determined correctly                  */
/*      1991-09-17 : subtract lb(mainarray) from lb(subarray)   */
/*      1991-05-29 : descrtype * replaced by y_dscp             */
/*      1990-07-31 : char changed to a_char                     */
/*      1990-07-04 : LINT_ARGS prototype                        */
/****************************************************************/

#ifndef ALL_IN_ONE
#ifdef AIX
#include "/u/p88c/runtime/o_defs.h"
#else
#include "o_defs.h"
#endif
#define local
#endif

#ifdef LINT_ARGS
#if C_P_7
local a_VOID y_suba(a_VOID m,a_VOID s,a_char *mode,...)
#else
local a_VOID y_suba(m,s,mode,e_args)
a_VOID m;
a_VOID s;
a_char *mode;
e_list
#endif
#else
local a_VOID y_suba(m,s,mode,e_args)
a_VOID m;
a_VOID s;
a_char *mode;
e_list
#endif

{
        a_byte dim,sdim,i,j;
        a_byte length = (a_byte) strlen((char*) mode);
        a_btyp offset;
        va_list e_argv;

        E_TPUSH("y_suba")

        e_open(mode);

        /* dimension of main array */
        sdim = dim = ((y_desc *)m)->numdim;

        /* computation of the new subarray descriptor out of    */
        /* the main array descriptor                            */

        /* j = actual index position of subarray */
        offset = j = i = 0;

        /* scan characters of mode string */
        for (;i<length;i++)
           {

           /* get bounds and stride of index range for subarray index */
           switch (mode[i])
              {

              /* the whole index range of the main array        */
              /* is taken for the subarray                      */
              case '0': ((y_desc *)s)->fd[j].lbound =
                           ((y_desc *)m)->fd[i].lbound;
                        ((y_desc *)s)->fd[j].ubound =
                           ((y_desc *)m)->fd[i].ubound;
                        ((y_desc *)s)->fd[j].stride =
                           ((y_desc *)m)->fd[i].stride;
                        j++;
                        break;

              /* no subarray dimension in case of a single      */
              /* constant index value                           */
              /* possible pointer allignment problems           */
              case '1': 
				  { a_intg index = e_ref(a_intg);

				    if (((y_dscp)m)->fd[i].lbound > index ||
					   ((y_dscp)m)->fd[i].ubound < index)
                        {
                          e_trap(INDEX_RANGE,8,E_TMSG,67,
                                 E_TINT+E_TEXT(11),&index,
                                 E_TINT+E_TEXT(5),&((y_desc *)m)->fd[i].lbound,
                                 E_TINT+E_TEXT(6),&((y_desc *)m)->fd[i].ubound);
                          e_shut;
                          E_TPOPP("y_suba")
                          return((a_VOID) s);
			         }	

				    offset += (index-((y_desc *)m)->fd[i].lbound)*
                                  ((y_desc *)m)->fd[i].stride;
                        sdim--;
                        break;
                      }
              /* both indexranges are taken from the arg_list   */
              /* possible pointer allignment problems           */
              case '2': ((y_desc *)s)->fd[j].lbound = e_ref(a_intg);

              /* possible pointer allignment problems           */
                        ((y_desc *)s)->fd[j].ubound = e_ref(a_intg);
				    if (((y_dscp)s)->fd[j].lbound < 
					   ((y_dscp)m)->fd[i].lbound ||
				        ((y_dscp)s)->fd[j].ubound > 
					   ((y_dscp)m)->fd[i].ubound )
                        {
					 a_intg k;
					 k=j+1;
                          e_trap(INDEX_RANGE,12,E_TMSG,67,
                                 E_TINT+E_TEXT(11),&k,
                                 E_TINT+E_TEXT(5),&((y_desc *)s)->fd[j].lbound,
                                 E_TINT+E_TEXT(6),&((y_desc *)s)->fd[j].ubound,
                                 E_TINT+E_TEXT(5),&((y_desc *)m)->fd[i].lbound,
                                 E_TINT+E_TEXT(6),&((y_desc *)m)->fd[i].ubound);
                          e_shut;
                          E_TPOPP("y_suba")
                          return((a_VOID) s);
			         }	

                        ((y_desc *)s)->fd[j].stride =
                           ((y_desc *)m)->fd[i].stride;
                        offset += (((y_desc *)s)->fd[i].lbound-
                                   ((y_desc *)m)->fd[j].lbound)*
                                  ((y_desc *)m)->fd[i].stride;
                        j++;
                        break;

              /* the lower bound is taken from the arg_list     */
              /* possible pointer allignment problems           */
              case '3': ((y_desc *)s)->fd[j].lbound = e_ref(a_intg);
                        ((y_desc *)s)->fd[j].ubound =
                           ((y_desc *)m)->fd[i].ubound;

				    if (((y_dscp)s)->fd[j].lbound < 
					   ((y_dscp)m)->fd[i].lbound)
                        {
					 a_intg k;
					 k=j+1;
                          e_trap(INDEX_RANGE,12,E_TMSG,67,
                                 E_TINT+E_TEXT(11),&k,
                                 E_TINT+E_TEXT(5),&((y_desc *)s)->fd[j].lbound,
                                 E_TINT+E_TEXT(6),&((y_desc *)s)->fd[j].ubound,
                                 E_TINT+E_TEXT(5),&((y_desc *)m)->fd[i].lbound,
                                 E_TINT+E_TEXT(6),&((y_desc *)m)->fd[i].ubound);
                          e_shut;
                          E_TPOPP("y_suba")
                          return((a_VOID) s);
			         }	

                        ((y_desc *)s)->fd[j].stride =
                           ((y_desc *)m)->fd[i].stride;
                        offset += (((y_desc *)s)->fd[i].lbound-
                                   ((y_desc *)m)->fd[j].lbound)*
                                  ((y_desc *)m)->fd[i].stride;
                        j++;
                        break;

              /* the upper bound is taken from the arg_list     */
              /* possible pointer allignment problems           */
              case '4': ((y_desc *)s)->fd[j].ubound = e_ref(a_intg);
                        ((y_desc *)s)->fd[j].lbound =
                           ((y_desc *)m)->fd[i].lbound;

				    if ( ((y_dscp)s)->fd[j].ubound > 
					   ((y_dscp)m)->fd[i].ubound )
                        {
					 a_intg k;
					 k=j+1;
                          e_trap(INDEX_RANGE,12,E_TMSG,67,
                                 E_TINT+E_TEXT(11),&k,
                                 E_TINT+E_TEXT(5),&((y_desc *)s)->fd[j].lbound,
                                 E_TINT+E_TEXT(6),&((y_desc *)s)->fd[j].ubound,
                                 E_TINT+E_TEXT(5),&((y_desc *)m)->fd[i].lbound,
                                 E_TINT+E_TEXT(6),&((y_desc *)m)->fd[i].ubound);
                          e_shut;
                          E_TPOPP("y_suba")
                          return((a_VOID) s);
			         }	
                        ((y_desc *)s)->fd[j].stride =
                           ((y_desc *)m)->fd[i].stride;
                        j++;
                        break;

              default : ;
              }
           }

        e_shut;

        /* The higher indexranges which are not in the arg_list */
        /* are taken from the mainarray.                        */
        for (i=length;i<dim;i++)
           {
           ((y_desc *)s)->fd[j].lbound = ((y_desc *)m)->fd[i].lbound;
           ((y_desc *)s)->fd[j].ubound = ((y_desc *)m)->fd[i].ubound;
           ((y_desc *)s)->fd[j].stride = ((y_desc *)m)->fd[i].stride;
           j++;
           }

        ((y_desc *)s)->subarr = TRUE;
        ((y_desc *)s)->destroy = FALSE;
        ((y_desc *)s)->elsize = ((y_desc *)m)->elsize;
        ((y_desc *)s)->numdim = sdim;

	   /* assign sub(m) to s if is m allocated */
	   if (!y_aled(m) ) ((y_desc *)s)->array = NULL;
        else ((y_desc *)s)->array = (char *)((y_desc *)m)->array+
                                    ((y_desc *)m)->elsize*offset;

        ((y_desc *)s)->elnum = 1;
        for (j=0;j<sdim;j++)
           ((y_desc *)s)->elnum *= (size_t) (((y_desc *)s)->fd[j].ubound-
                                   ((y_desc *)s)->fd[j].lbound+1);

        E_TPOPP("y_suba")
        return((a_VOID) s);
        }
