[thirdparty/gcc.git] / libgfortran / generated / reshape_r4.c

/* Implementation of the RESHAPE
   Copyright 2002, 2006, 2007 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

This file is part of the GNU Fortran 95 runtime library (libgfortran).

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

In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file.  (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)

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

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

#include "libgfortran.h"
#include <stdlib.h>
#include <assert.h>


#if defined (HAVE_GFC_REAL_4)

typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;


extern void reshape_r4 (gfc_array_r4 * const restrict, 
	gfc_array_r4 * const restrict, 
	shape_type * const restrict,
	gfc_array_r4 * const restrict, 
	shape_type * const restrict);
export_proto(reshape_r4);

void
reshape_r4 (gfc_array_r4 * const restrict ret, 
	gfc_array_r4 * const restrict source, 
	shape_type * const restrict shape,
	gfc_array_r4 * const restrict pad, 
	shape_type * const restrict order)
{
  /* r.* indicates the return array.  */
  index_type rcount[GFC_MAX_DIMENSIONS];
  index_type rextent[GFC_MAX_DIMENSIONS];
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type rdim;
  index_type rsize;
  index_type rs;
  index_type rex;
  GFC_REAL_4 *rptr;
  /* s.* indicates the source array.  */
  index_type scount[GFC_MAX_DIMENSIONS];
  index_type sextent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  index_type sdim;
  index_type ssize;
  const GFC_REAL_4 *sptr;
  /* p.* indicates the pad array.  */
  index_type pcount[GFC_MAX_DIMENSIONS];
  index_type pextent[GFC_MAX_DIMENSIONS];
  index_type pstride[GFC_MAX_DIMENSIONS];
  index_type pdim;
  index_type psize;
  const GFC_REAL_4 *pptr;

  const GFC_REAL_4 *src;
  int n;
  int dim;
  int sempty, pempty, shape_empty;
  index_type shape_data[GFC_MAX_DIMENSIONS];

  rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
  if (rdim != GFC_DESCRIPTOR_RANK(ret))
    runtime_error("rank of return array incorrect in RESHAPE intrinsic");

  shape_empty = 0;

  for (n = 0; n < rdim; n++)
    {
      shape_data[n] = shape->data[n * shape->dim[0].stride];
      if (shape_data[n] <= 0)
      {
        shape_data[n] = 0;
	shape_empty = 1;
      }
    }

  if (ret->data == NULL)
    {
      rs = 1;
      for (n = 0; n < rdim; n++)
	{
	  ret->dim[n].lbound = 0;
	  rex = shape_data[n];
	  ret->dim[n].ubound =  rex - 1;
	  ret->dim[n].stride = rs;
	  rs *= rex;
	}
      ret->offset = 0;
      ret->data = internal_malloc_size ( rs * sizeof (GFC_REAL_4));
      ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim;
    }

  if (shape_empty)
    return;

  if (unlikely (compile_options.bounds_check))
    {
      if (order)
	{
	  int seen[GFC_MAX_DIMENSIONS];
	  index_type v;

	  for (n = 0; n < rdim; n++)
	    seen[n] = 0;

	  for (n = 0; n < rdim; n++)
	    {
	      v = order->data[n * order->dim[0].stride] - 1;

	      if (v < 0 || v >= rdim)
		runtime_error("Value %ld out of range in ORDER argument"
			      " to RESHAPE intrinsic", (long int) v + 1);

	      if (seen[v] != 0)
		runtime_error("Duplicate value %ld in ORDER argument to"
			      " RESHAPE intrinsic", (long int) v + 1);
		
	      seen[v] = 1;
	    }
	}
    }

  rsize = 1;
  for (n = 0; n < rdim; n++)
    {
      if (order)
        dim = order->data[n * order->dim[0].stride] - 1;
      else
        dim = n;

      rcount[n] = 0;
      rstride[n] = ret->dim[dim].stride;
      rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound;
      if (rextent[n] < 0)
        rextent[n] = 0;

      if (rextent[n] != shape_data[dim])
        runtime_error ("shape and target do not conform");

      if (rsize == rstride[n])
        rsize *= rextent[n];
      else
        rsize = 0;
      if (rextent[n] <= 0)
        return;
    }

  sdim = GFC_DESCRIPTOR_RANK (source);
  ssize = 1;
  sempty = 0;
  for (n = 0; n < sdim; n++)
    {
      scount[n] = 0;
      sstride[n] = source->dim[n].stride;
      sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
      if (sextent[n] <= 0)
	{
	  sempty = 1;
	  sextent[n] = 0;
	}

      if (ssize == sstride[n])
        ssize *= sextent[n];
      else
        ssize = 0;
    }

  if (pad)
    {
      pdim = GFC_DESCRIPTOR_RANK (pad);
      psize = 1;
      pempty = 0;
      for (n = 0; n < pdim; n++)
        {
          pcount[n] = 0;
          pstride[n] = pad->dim[n].stride;
          pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound;
          if (pextent[n] <= 0)
	    {
	      pempty = 1;
	      pextent[n] = 0;
	    }

          if (psize == pstride[n])
            psize *= pextent[n];
          else
            psize = 0;
        }
      pptr = pad->data;
    }
  else
    {
      pdim = 0;
      psize = 1;
      pempty = 1;
      pptr = NULL;
    }

  if (rsize != 0 && ssize != 0 && psize != 0)
    {
      rsize *= sizeof (GFC_REAL_4);
      ssize *= sizeof (GFC_REAL_4);
      psize *= sizeof (GFC_REAL_4);
      reshape_packed ((char *)ret->data, rsize, (char *)source->data,
		      ssize, pad ? (char *)pad->data : NULL, psize);
      return;
    }
  rptr = ret->data;
  src = sptr = source->data;
  rstride0 = rstride[0];
  sstride0 = sstride[0];

  if (sempty && pempty)
    abort ();

  if (sempty)
    {
      /* Switch immediately to the pad array.  */
      src = pptr;
      sptr = NULL;
      sdim = pdim;
      for (dim = 0; dim < pdim; dim++)
	{
	  scount[dim] = pcount[dim];
	  sextent[dim] = pextent[dim];
	  sstride[dim] = pstride[dim];
	  sstride0 = sstride[0] * sizeof (GFC_REAL_4);
	}
    }

  while (rptr)
    {
      /* Select between the source and pad arrays.  */
      *rptr = *src;
      /* Advance to the next element.  */
      rptr += rstride0;
      src += sstride0;
      rcount[0]++;
      scount[0]++;

      /* Advance to the next destination element.  */
      n = 0;
      while (rcount[n] == rextent[n])
        {
          /* When we get to the end of a dimension, reset it and increment
             the next dimension.  */
          rcount[n] = 0;
          /* We could precalculate these products, but this is a less
             frequently used path so probably not worth it.  */
          rptr -= rstride[n] * rextent[n];
          n++;
          if (n == rdim)
            {
              /* Break out of the loop.  */
              rptr = NULL;
              break;
            }
          else
            {
              rcount[n]++;
              rptr += rstride[n];
            }
        }
      /* Advance to the next source element.  */
      n = 0;
      while (scount[n] == sextent[n])
        {
          /* When we get to the end of a dimension, reset it and increment
             the next dimension.  */
          scount[n] = 0;
          /* We could precalculate these products, but this is a less
             frequently used path so probably not worth it.  */
          src -= sstride[n] * sextent[n];
          n++;
          if (n == sdim)
            {
              if (sptr && pad)
                {
                  /* Switch to the pad array.  */
                  sptr = NULL;
                  sdim = pdim;
                  for (dim = 0; dim < pdim; dim++)
                    {
                      scount[dim] = pcount[dim];
                      sextent[dim] = pextent[dim];
                      sstride[dim] = pstride[dim];
                      sstride0 = sstride[0];
                    }
                }
              /* We now start again from the beginning of the pad array.  */
              src = pptr;
              break;
            }
          else
            {
              scount[n]++;
              src += sstride[n];
            }
        }
    }
}

#endif
Commit	Line	Data
ecebfb8b	1	/* Implementation of the RESHAPE
36ae8a61	2	Copyright 2002, 2006, 2007 Free Software Foundation, Inc.
ecebfb8b FXC	3	Contributed by Paul Brook <paul@nowt.org>
	4
	5	This file is part of the GNU Fortran 95 runtime library (libgfortran).
	6
	7	Libgfortran is free software; you can redistribute it and/or
	8	modify it under the terms of the GNU General Public
	9	License as published by the Free Software Foundation; either
	10	version 2 of the License, or (at your option) any later version.
	11
	12	In addition to the permissions in the GNU General Public License, the
	13	Free Software Foundation gives you unlimited permission to link the
	14	compiled version of this file into combinations with other programs,
	15	and to distribute those combinations without any restriction coming
	16	from the use of this file. (The General Public License restrictions
	17	do apply in other respects; for example, they cover modification of
	18	the file, and distribution when not linked into a combine
	19	executable.)
	20
	21	Libgfortran is distributed in the hope that it will be useful,
	22	but WITHOUT ANY WARRANTY; without even the implied warranty of
	23	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	24	GNU General Public License for more details.
	25
	26	You should have received a copy of the GNU General Public
	27	License along with libgfortran; see the file COPYING. If not,
	28	write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
	29	Boston, MA 02110-1301, USA. */
	30
36ae8a61	31	#include "libgfortran.h"
ecebfb8b FXC	32	#include <stdlib.h>
ecebfb8b FXC	33	#include <assert.h>
36ae8a61	34
ecebfb8b FXC	35
	36	#if defined (HAVE_GFC_REAL_4)
	37
	38	typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;
	39
ecebfb8b FXC	40
	41	extern void reshape_r4 (gfc_array_r4 * const restrict,
	42	gfc_array_r4 * const restrict,
	43	shape_type * const restrict,
	44	gfc_array_r4 * const restrict,
	45	shape_type * const restrict);
	46	export_proto(reshape_r4);
	47
	48	void
	49	reshape_r4 (gfc_array_r4 * const restrict ret,
	50	gfc_array_r4 * const restrict source,
	51	shape_type * const restrict shape,
	52	gfc_array_r4 * const restrict pad,
	53	shape_type * const restrict order)
	54	{
	55	/* r.* indicates the return array. */
	56	index_type rcount[GFC_MAX_DIMENSIONS];
	57	index_type rextent[GFC_MAX_DIMENSIONS];
	58	index_type rstride[GFC_MAX_DIMENSIONS];
	59	index_type rstride0;
	60	index_type rdim;
	61	index_type rsize;
	62	index_type rs;
	63	index_type rex;
	64	GFC_REAL_4 *rptr;
	65	/* s.* indicates the source array. */
	66	index_type scount[GFC_MAX_DIMENSIONS];
	67	index_type sextent[GFC_MAX_DIMENSIONS];
	68	index_type sstride[GFC_MAX_DIMENSIONS];
	69	index_type sstride0;
	70	index_type sdim;
	71	index_type ssize;
	72	const GFC_REAL_4 *sptr;
	73	/* p.* indicates the pad array. */
	74	index_type pcount[GFC_MAX_DIMENSIONS];
	75	index_type pextent[GFC_MAX_DIMENSIONS];
	76	index_type pstride[GFC_MAX_DIMENSIONS];
	77	index_type pdim;
	78	index_type psize;
	79	const GFC_REAL_4 *pptr;
	80
	81	const GFC_REAL_4 *src;
	82	int n;
	83	int dim;
8c154b65 TK	84	int sempty, pempty, shape_empty;
	85	index_type shape_data[GFC_MAX_DIMENSIONS];
	86
	87	rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
	88	if (rdim != GFC_DESCRIPTOR_RANK(ret))
	89	runtime_error("rank of return array incorrect in RESHAPE intrinsic");
	90
	91	shape_empty = 0;
	92
	93	for (n = 0; n < rdim; n++)
	94	{
	95	shape_data[n] = shape->data[n * shape->dim[0].stride];
	96	if (shape_data[n] <= 0)
	97	{
	98	shape_data[n] = 0;
	99	shape_empty = 1;
	100	}
	101	}
ecebfb8b FXC	102
	103	if (ret->data == NULL)
	104	{
ecebfb8b	105	rs = 1;
47c07d96	106	for (n = 0; n < rdim; n++)
ecebfb8b FXC	107	{
ecebfb8b FXC	108	ret->dim[n].lbound = 0;
8c154b65	109	rex = shape_data[n];
ecebfb8b FXC	110	ret->dim[n].ubound = rex - 1;
	111	ret->dim[n].stride = rs;
	112	rs *= rex;
	113	}
	114	ret->offset = 0;
	115	ret->data = internal_malloc_size ( rs * sizeof (GFC_REAL_4));
	116	ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) \| rdim;
	117	}
8c154b65 TK	118
	119	if (shape_empty)
	120	return;
ecebfb8b	121
fd7f9754 TK	122	if (unlikely (compile_options.bounds_check))
	123	{
	124	if (order)
	125	{
	126	int seen[GFC_MAX_DIMENSIONS];
	127	index_type v;
	128
	129	for (n = 0; n < rdim; n++)
	130	seen[n] = 0;
	131
	132	for (n = 0; n < rdim; n++)
	133	{
	134	v = order->data[n * order->dim[0].stride] - 1;
	135
	136	if (v < 0 \|\| v >= rdim)
	137	runtime_error("Value %ld out of range in ORDER argument"
	138	" to RESHAPE intrinsic", (long int) v + 1);
	139
	140	if (seen[v] != 0)
	141	runtime_error("Duplicate value %ld in ORDER argument to"
	142	" RESHAPE intrinsic", (long int) v + 1);
	143
	144	seen[v] = 1;
	145	}
	146	}
	147	}
	148
ecebfb8b FXC	149	rsize = 1;
	150	for (n = 0; n < rdim; n++)
	151	{
	152	if (order)
	153	dim = order->data[n * order->dim[0].stride] - 1;
	154	else
	155	dim = n;
	156
	157	rcount[n] = 0;
	158	rstride[n] = ret->dim[dim].stride;
	159	rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound;
8c154b65	160	if (rextent[n] < 0)
e94471ba	161	rextent[n] = 0;
ecebfb8b	162
8c154b65	163	if (rextent[n] != shape_data[dim])
ecebfb8b FXC	164	runtime_error ("shape and target do not conform");
	165
	166	if (rsize == rstride[n])
	167	rsize *= rextent[n];
	168	else
	169	rsize = 0;
	170	if (rextent[n] <= 0)
	171	return;
	172	}
	173
	174	sdim = GFC_DESCRIPTOR_RANK (source);
	175	ssize = 1;
47c07d96	176	sempty = 0;
ecebfb8b FXC	177	for (n = 0; n < sdim; n++)
	178	{
	179	scount[n] = 0;
	180	sstride[n] = source->dim[n].stride;
	181	sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
	182	if (sextent[n] <= 0)
47c07d96 FXC	183	{
	184	sempty = 1;
	185	sextent[n] = 0;
	186	}
ecebfb8b FXC	187
	188	if (ssize == sstride[n])
	189	ssize *= sextent[n];
	190	else
	191	ssize = 0;
	192	}
	193
	194	if (pad)
	195	{
	196	pdim = GFC_DESCRIPTOR_RANK (pad);
	197	psize = 1;
47c07d96	198	pempty = 0;
ecebfb8b FXC	199	for (n = 0; n < pdim; n++)
	200	{
	201	pcount[n] = 0;
	202	pstride[n] = pad->dim[n].stride;
	203	pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound;
	204	if (pextent[n] <= 0)
47c07d96 FXC	205	{
	206	pempty = 1;
	207	pextent[n] = 0;
	208	}
	209
ecebfb8b FXC	210	if (psize == pstride[n])
	211	psize *= pextent[n];
	212	else
	213	psize = 0;
	214	}
	215	pptr = pad->data;
	216	}
	217	else
	218	{
	219	pdim = 0;
	220	psize = 1;
47c07d96	221	pempty = 1;
ecebfb8b FXC	222	pptr = NULL;
	223	}
	224
	225	if (rsize != 0 && ssize != 0 && psize != 0)
	226	{
	227	rsize *= sizeof (GFC_REAL_4);
	228	ssize *= sizeof (GFC_REAL_4);
	229	psize *= sizeof (GFC_REAL_4);
	230	reshape_packed ((char )ret->data, rsize, (char )source->data,
	231	ssize, pad ? (char *)pad->data : NULL, psize);
	232	return;
	233	}
	234	rptr = ret->data;
	235	src = sptr = source->data;
	236	rstride0 = rstride[0];
	237	sstride0 = sstride[0];
	238
47c07d96 FXC	239	if (sempty && pempty)
	240	abort ();
	241
	242	if (sempty)
	243	{
	244	/* Switch immediately to the pad array. */
	245	src = pptr;
	246	sptr = NULL;
	247	sdim = pdim;
	248	for (dim = 0; dim < pdim; dim++)
	249	{
	250	scount[dim] = pcount[dim];
	251	sextent[dim] = pextent[dim];
	252	sstride[dim] = pstride[dim];
	253	sstride0 = sstride[0] * sizeof (GFC_REAL_4);
	254	}
	255	}
	256
ecebfb8b FXC	257	while (rptr)
	258	{
	259	/* Select between the source and pad arrays. */
	260	rptr = src;
	261	/* Advance to the next element. */
	262	rptr += rstride0;
	263	src += sstride0;
	264	rcount[0]++;
	265	scount[0]++;
47c07d96	266
ecebfb8b FXC	267	/* Advance to the next destination element. */
	268	n = 0;
	269	while (rcount[n] == rextent[n])
	270	{
	271	/* When we get to the end of a dimension, reset it and increment
	272	the next dimension. */
	273	rcount[n] = 0;
	274	/* We could precalculate these products, but this is a less
5d7adf7a	275	frequently used path so probably not worth it. */
ecebfb8b FXC	276	rptr -= rstride[n] * rextent[n];
	277	n++;
	278	if (n == rdim)
	279	{
	280	/* Break out of the loop. */
	281	rptr = NULL;
	282	break;
	283	}
	284	else
	285	{
	286	rcount[n]++;
	287	rptr += rstride[n];
	288	}
	289	}
	290	/* Advance to the next source element. */
	291	n = 0;
	292	while (scount[n] == sextent[n])
	293	{
	294	/* When we get to the end of a dimension, reset it and increment
	295	the next dimension. */
	296	scount[n] = 0;
	297	/* We could precalculate these products, but this is a less
5d7adf7a	298	frequently used path so probably not worth it. */
ecebfb8b FXC	299	src -= sstride[n] * sextent[n];
	300	n++;
	301	if (n == sdim)
	302	{
	303	if (sptr && pad)
	304	{
	305	/* Switch to the pad array. */
	306	sptr = NULL;
	307	sdim = pdim;
	308	for (dim = 0; dim < pdim; dim++)
	309	{
	310	scount[dim] = pcount[dim];
	311	sextent[dim] = pextent[dim];
	312	sstride[dim] = pstride[dim];
	313	sstride0 = sstride[0];
	314	}
	315	}
	316	/* We now start again from the beginning of the pad array. */
	317	src = pptr;
	318	break;
	319	}
	320	else
	321	{
	322	scount[n]++;
	323	src += sstride[n];
	324	}
	325	}
	326	}
	327	}
	328
	329	#endif