[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;

  if (ret->data == NULL)
    {
      rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
      rs = 1;
      for (n = 0; n < rdim; n++)
	{
	  ret->dim[n].lbound = 0;
	  rex = shape->data[n * shape->dim[0].stride];
	  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;
    }
  else
    {
      rdim = GFC_DESCRIPTOR_RANK (ret);
    }

  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] != shape->data[dim * shape->dim[0].stride])
        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;
47c07d96	84	int sempty, pempty;
ecebfb8b FXC	85
	86	if (ret->data == NULL)
	87	{
	88	rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
	89	rs = 1;
47c07d96	90	for (n = 0; n < rdim; n++)
ecebfb8b FXC	91	{
	92	ret->dim[n].lbound = 0;
	93	rex = shape->data[n * shape->dim[0].stride];
	94	ret->dim[n].ubound = rex - 1;
	95	ret->dim[n].stride = rs;
	96	rs *= rex;
	97	}
	98	ret->offset = 0;
	99	ret->data = internal_malloc_size ( rs * sizeof (GFC_REAL_4));
	100	ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) \| rdim;
	101	}
	102	else
	103	{
	104	rdim = GFC_DESCRIPTOR_RANK (ret);
	105	}
	106
	107	rsize = 1;
	108	for (n = 0; n < rdim; n++)
	109	{
	110	if (order)
	111	dim = order->data[n * order->dim[0].stride] - 1;
	112	else
	113	dim = n;
	114
	115	rcount[n] = 0;
	116	rstride[n] = ret->dim[dim].stride;
	117	rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound;
	118
	119	if (rextent[n] != shape->data[dim * shape->dim[0].stride])
	120	runtime_error ("shape and target do not conform");
	121
	122	if (rsize == rstride[n])
	123	rsize *= rextent[n];
	124	else
	125	rsize = 0;
	126	if (rextent[n] <= 0)
	127	return;
	128	}
	129
	130	sdim = GFC_DESCRIPTOR_RANK (source);
	131	ssize = 1;
47c07d96	132	sempty = 0;
ecebfb8b FXC	133	for (n = 0; n < sdim; n++)
	134	{
	135	scount[n] = 0;
	136	sstride[n] = source->dim[n].stride;
	137	sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
	138	if (sextent[n] <= 0)
47c07d96 FXC	139	{
	140	sempty = 1;
	141	sextent[n] = 0;
	142	}
ecebfb8b FXC	143
	144	if (ssize == sstride[n])
	145	ssize *= sextent[n];
	146	else
	147	ssize = 0;
	148	}
	149
	150	if (pad)
	151	{
	152	pdim = GFC_DESCRIPTOR_RANK (pad);
	153	psize = 1;
47c07d96	154	pempty = 0;
ecebfb8b FXC	155	for (n = 0; n < pdim; n++)
	156	{
	157	pcount[n] = 0;
	158	pstride[n] = pad->dim[n].stride;
	159	pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound;
	160	if (pextent[n] <= 0)
47c07d96 FXC	161	{
	162	pempty = 1;
	163	pextent[n] = 0;
	164	}
	165
ecebfb8b FXC	166	if (psize == pstride[n])
	167	psize *= pextent[n];
	168	else
	169	psize = 0;
	170	}
	171	pptr = pad->data;
	172	}
	173	else
	174	{
	175	pdim = 0;
	176	psize = 1;
47c07d96	177	pempty = 1;
ecebfb8b FXC	178	pptr = NULL;
	179	}
	180
	181	if (rsize != 0 && ssize != 0 && psize != 0)
	182	{
	183	rsize *= sizeof (GFC_REAL_4);
	184	ssize *= sizeof (GFC_REAL_4);
	185	psize *= sizeof (GFC_REAL_4);
	186	reshape_packed ((char )ret->data, rsize, (char )source->data,
	187	ssize, pad ? (char *)pad->data : NULL, psize);
	188	return;
	189	}
	190	rptr = ret->data;
	191	src = sptr = source->data;
	192	rstride0 = rstride[0];
	193	sstride0 = sstride[0];
	194
47c07d96 FXC	195	if (sempty && pempty)
	196	abort ();
	197
	198	if (sempty)
	199	{
	200	/* Switch immediately to the pad array. */
	201	src = pptr;
	202	sptr = NULL;
	203	sdim = pdim;
	204	for (dim = 0; dim < pdim; dim++)
	205	{
	206	scount[dim] = pcount[dim];
	207	sextent[dim] = pextent[dim];
	208	sstride[dim] = pstride[dim];
	209	sstride0 = sstride[0] * sizeof (GFC_REAL_4);
	210	}
	211	}
	212
ecebfb8b FXC	213	while (rptr)
	214	{
	215	/* Select between the source and pad arrays. */
	216	rptr = src;
	217	/* Advance to the next element. */
	218	rptr += rstride0;
	219	src += sstride0;
	220	rcount[0]++;
	221	scount[0]++;
47c07d96	222
ecebfb8b FXC	223	/* Advance to the next destination element. */
	224	n = 0;
	225	while (rcount[n] == rextent[n])
	226	{
	227	/* When we get to the end of a dimension, reset it and increment
	228	the next dimension. */
	229	rcount[n] = 0;
	230	/* We could precalculate these products, but this is a less
5d7adf7a	231	frequently used path so probably not worth it. */
ecebfb8b FXC	232	rptr -= rstride[n] * rextent[n];
	233	n++;
	234	if (n == rdim)
	235	{
	236	/* Break out of the loop. */
	237	rptr = NULL;
	238	break;
	239	}
	240	else
	241	{
	242	rcount[n]++;
	243	rptr += rstride[n];
	244	}
	245	}
	246	/* Advance to the next source element. */
	247	n = 0;
	248	while (scount[n] == sextent[n])
	249	{
	250	/* When we get to the end of a dimension, reset it and increment
	251	the next dimension. */
	252	scount[n] = 0;
	253	/* We could precalculate these products, but this is a less
5d7adf7a	254	frequently used path so probably not worth it. */
ecebfb8b FXC	255	src -= sstride[n] * sextent[n];
	256	n++;
	257	if (n == sdim)
	258	{
	259	if (sptr && pad)
	260	{
	261	/* Switch to the pad array. */
	262	sptr = NULL;
	263	sdim = pdim;
	264	for (dim = 0; dim < pdim; dim++)
	265	{
	266	scount[dim] = pcount[dim];
	267	sextent[dim] = pextent[dim];
	268	sstride[dim] = pstride[dim];
	269	sstride0 = sstride[0];
	270	}
	271	}
	272	/* We now start again from the beginning of the pad array. */
	273	src = pptr;
	274	break;
	275	}
	276	else
	277	{
	278	scount[n]++;
	279	src += sstride[n];
	280	}
	281	}
	282	}
	283	}
	284
	285	#endif