Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
00001 /* 00002 00003 Copyright (C) 2000, 2001 Silicon Graphics, Inc. All Rights Reserved. 00004 00005 This program is free software; you can redistribute it and/or modify it 00006 under the terms of version 2.1 of the GNU Lesser General Public License 00007 as published by the Free Software Foundation. 00008 00009 This program is distributed in the hope that it would be useful, but 00010 WITHOUT ANY WARRANTY; without even the implied warranty of 00011 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00012 00013 Further, this software is distributed without any warranty that it is 00014 free of the rightful claim of any third person regarding infringement 00015 or the like. Any license provided herein, whether implied or 00016 otherwise, applies only to this software file. Patent licenses, if 00017 any, provided herein do not apply to combinations of this program with 00018 other software, or any other product whatsoever. 00019 00020 You should have received a copy of the GNU Lesser General Public 00021 License along with this program; if not, write the Free Software 00022 Foundation, Inc., 59 Temple Place - Suite 330, Boston MA 02111-1307, 00023 USA. 00024 00025 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00026 Mountain View, CA 94043, or: 00027 00028 http://www.sgi.com 00029 00030 For further information regarding this notice, see: 00031 00032 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00033 00034 */ 00035 00036 00037 #pragma ident "@(#) libfi/array/lbound.c 92.2 07/07/99 15:52:02" 00038 #include <liberrno.h> 00039 #include <stddef.h> 00040 #include <cray/dopevec.h> 00041 #include <cray/portdefs.h> 00042 00043 #include <stdlib.h> 00044 00045 #define BITS_PER_BYTE (BITS_PER_WORD / BYTES_PER_WORD) 00046 00047 /* 00048 * LBOUND Returns the low_bounds for a source array in a rank one 00049 * result array. A null argument DIM is present but not used. 00050 * If source pointer/allocatable array is not 00051 * associated/allocated, return an error. 00052 * If result rank one array has not been allocated, fill parts 00053 * of result dope vector and allocate space for result. 00054 * When extent of a dimension is nonzero, lbound = low_bound. 00055 * Otherwise, lbound=one. 00056 */ 00057 00058 void 00059 _LBOUND (DopeVectorType * result, 00060 DopeVectorType * source, 00061 _f_int *dimptr) 00062 { 00063 int rank; 00064 int numbytes; 00065 int *destarry; 00066 _f_int4 *resptr4; 00067 _f_int8 *resptr8; 00068 int loopj; 00069 00070 /* If source is a pointer/allocatable array, it must be 00071 * associated/allocated. */ 00072 if (source->p_or_a && !source->assoc) 00073 _lerror ( _LELVL_ABORT, FENMPTAR, "LBOUND"); 00074 00075 /* target is rank-one array with extent source.n_dim */ 00076 rank = source->n_dim; 00077 00078 /* If result array is not allocated */ 00079 if (!result->assoc) { 00080 result->base_addr.a.ptr = (void *) NULL; 00081 result->dimension[0].extent = rank; 00082 result->dimension[0].low_bound = 1; 00083 result->dimension[0].stride_mult = 00084 result->type_lens.int_len / (sizeof(_f_int) * 00085 BITS_PER_BYTE); 00086 numbytes = rank * BYTES_PER_WORD; 00087 /* allocate rank in bytes for temporary array */ 00088 destarry = (void *) malloc (numbytes); 00089 if (destarry == NULL) 00090 _lerror(_LELVL_ABORT,FENOMEMY); 00091 result->base_addr.a.ptr = (void *) destarry; 00092 result->assoc = 1; 00093 } 00094 00095 if (result->type_lens.kind_or_star == 0) { 00096 if (result->type_lens.int_len == 64) { 00097 resptr8 = (_f_int8 *) result->base_addr.a.ptr; 00098 for (loopj = 0; loopj < rank; loopj++) 00099 if( source->dimension[loopj].extent != 0) 00100 resptr8[loopj] = (_f_int8) 00101 source->dimension[loopj].low_bound; 00102 else 00103 resptr8[loopj] = (_f_int8) 1; 00104 } else { 00105 resptr4 = (_f_int4 *) result->base_addr.a.ptr; 00106 for (loopj = 0; loopj < rank; loopj++) 00107 if( source->dimension[loopj].extent != 0) 00108 resptr4[loopj] = (_f_int4) 00109 source->dimension[loopj].low_bound; 00110 else 00111 resptr4[loopj] = (_f_int4) 1; 00112 } 00113 } else { 00114 if (result->type_lens.dec_len == 8) { 00115 resptr8 = (_f_int8 *) result->base_addr.a.ptr; 00116 for (loopj = 0; loopj < rank; loopj++) 00117 if( source->dimension[loopj].extent != 0) 00118 resptr8[loopj] = (_f_int8) 00119 source->dimension[loopj].low_bound; 00120 else 00121 resptr8[loopj] = (_f_int8) 1; 00122 } else if (result->type_lens.dec_len == 4) { 00123 resptr4 = (_f_int4 *) result->base_addr.a.ptr; 00124 for (loopj = 0; loopj < rank; loopj++) 00125 if( source->dimension[loopj].extent != 0) 00126 resptr4[loopj] = (_f_int4) 00127 source->dimension[loopj].low_bound; 00128 else 00129 resptr4[loopj] = (_f_int4) 1; 00130 } 00131 } 00132 } 00133 00134 /* 00135 * LBOUND0 Returns scalar low_bound for a specified dimension DIM of 00136 * an array. 00137 * If the source pointer/allocatable array is not 00138 * associated/allocated, return an error. 00139 * If DIM is outside the rank of the array, return an error. 00140 * When extent of specified dimension is nonzero, return 00141 * lbound=low_bound. Otherwise, return lbound=one. 00142 */ 00143 00144 _f_int 00145 _LBOUND0(DopeVectorType * source, 00146 _f_int *dimptr) 00147 { 00148 int iresult; 00149 int dim; 00150 int rank; 00151 00152 /* If source is a pointer/allocatable array, it must be 00153 * associated/allocated. */ 00154 if (source->p_or_a && !source->assoc) 00155 _lerror ( _LELVL_ABORT, FENMPTAR, "LBOUND"); 00156 00157 /* argument DIM must be within source array rank */ 00158 rank = source->n_dim; 00159 dim = *dimptr - 1; 00160 if (dim < 0 || dim >= rank) 00161 _lerror (_LELVL_ABORT, FENMSCDM, "LBOUND"); 00162 00163 /* Return low_bound for nonzero extent, else return one */ 00164 if(source->dimension[dim].extent != 0) 00165 iresult = source->dimension[dim].low_bound; 00166 else 00167 iresult = 1; 00168 00169 return(iresult); 00170 } 00171 00172 /* 00173 * LBOUND0_4 Returns scalar low_bound for a specified dimension DIM of 00174 * an array. 00175 * If the source pointer/allocatable array is not 00176 * associated/allocated, return an error. 00177 * If DIM is outside the rank of the array, return an error. 00178 * When extent of specified dimension is nonzero, return 00179 * lbound=low_bound. Otherwise, return lbound=one. 00180 */ 00181 00182 #if defined (_UNICOS) 00183 #pragma duplicate _LBOUND0_4 as _LBOUND0_2 00184 #pragma duplicate _LBOUND0_4 as _LBOUND0_1 00185 #endif 00186 00187 _f_int4 00188 _LBOUND0_4(DopeVectorType * source, 00189 _f_int *dimptr) 00190 { 00191 _f_int4 iresult; 00192 int dim; 00193 int rank; 00194 00195 /* If source is a pointer/allocatable array, it must be 00196 * associated/allocated. */ 00197 if (source->p_or_a && !source->assoc) 00198 _lerror ( _LELVL_ABORT, FENMPTAR, "LBOUND"); 00199 00200 /* argument DIM must be within source array rank */ 00201 rank = source->n_dim; 00202 dim = *dimptr - 1; 00203 if (dim < 0 || dim >= rank) 00204 _lerror (_LELVL_ABORT, FENMSCDM, "LBOUND"); 00205 00206 /* Return low_bound for nonzero extent, else return one */ 00207 if(source->dimension[dim].extent != 0) 00208 iresult = (_f_int4) source->dimension[dim].low_bound; 00209 else 00210 iresult = (_f_int4) 1; 00211 00212 return(iresult); 00213 } 00214 00215 /* 00216 * LBOUND0_8 Returns scalar low_bound for a specified dimension DIM of 00217 * an array. 00218 * If the source pointer/allocatable array is not 00219 * associated/allocated, return an error. 00220 * If DIM is outside the rank of the array, return an error. 00221 * When extent of specified dimension is nonzero, return 00222 * lbound=low_bound. Otherwise, return lbound=one. 00223 */ 00224 00225 _f_int8 00226 _LBOUND0_8(DopeVectorType * source, 00227 _f_int *dimptr) 00228 { 00229 _f_int8 iresult; 00230 int dim; 00231 int rank; 00232 00233 /* If source is a pointer/allocatable array, it must be 00234 * associated/allocated. */ 00235 if (source->p_or_a && !source->assoc) 00236 _lerror ( _LELVL_ABORT, FENMPTAR, "LBOUND"); 00237 00238 /* argument DIM must be within source array rank */ 00239 rank = source->n_dim; 00240 dim = *dimptr - 1; 00241 if (dim < 0 || dim >= rank) 00242 _lerror (_LELVL_ABORT, FENMSCDM, "LBOUND"); 00243 00244 /* Return low_bound for nonzero extent, else return one */ 00245 if(source->dimension[dim].extent != 0) 00246 iresult = (_f_int8) source->dimension[dim].low_bound; 00247 else 00248 iresult = (_f_int8) 1; 00249 00250 return(iresult); 00251 }