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 00038 #pragma ident "@(#) libf/fio/wnlutil.c 92.1 06/21/99 10:37:55" 00039 00040 #include <liberrno.h> 00041 #include <fortran.h> 00042 #include "fio.h" 00043 00044 #define WNLMIN 8L /* Minimum WNLLONG value */ 00045 00046 long _wnlrecsiz = -1; /* Length of output line. -1 indicates 00047 the default */ 00048 long OUT_CHAR = (long) '&'; /* Delimiter character preceding the 00049 group name and END */ 00050 long OUT_SEP = (long) ','; /* Separator character immediately 00051 following each value */ 00052 long OUT_EQ = (long) '='; /* Replacement operator that comes 00053 between name and value */ 00054 long OUT_ECHO = (long) ' '; /* Character written to column 1 */ 00055 00056 long OUT_LINE = 0; /* If nonzero, write a new line for 00057 each variable */ 00058 00059 /* 00060 * Return a character, which might be 'A', 'A'L, 'A'R, or 'A'H format. 00061 */ 00062 long 00063 _getfchar(_fcd fc) 00064 { 00065 long ret, x; 00066 00067 #if defined(_UNICOS) && (!defined(_ADDR64) && !defined(_WORD32)) 00068 if (!_isfcd(fc)) { 00069 x = *(long *)_fcdtocp(fc); 00070 ret = (x >> 56) & 0377; /* 'A'L or 'A'H format */ 00071 00072 if (ret == 0) 00073 ret = x & 0377; /* 'A'R format */ 00074 } 00075 else 00076 #endif 00077 ret = *(_fcdtocp(fc)); /* 'A' format */ 00078 00079 if (ret == 0) 00080 _ferr(NULL, FENLTYPE); 00081 00082 return(ret); 00083 } 00084 00085 #if defined(_UNICOS) 00086 /* 00087 * WNLLONG changes the maximum output record length for namelist writes 00088 * (note restrictions in wnly.c). 00089 */ 00090 WNLLONG(_f_int *length) 00091 { 00092 long len; 00093 00094 len = (long) *length; 00095 00096 if (len < 0) /* Restore default value */ 00097 _wnlrecsiz = -1L; 00098 else /* Enforce a floor */ 00099 if (len < WNLMIN) 00100 _wnlrecsiz = WNLMIN; 00101 else 00102 _wnlrecsiz = len; 00103 00104 return(0); 00105 } 00106 #endif 00107 00108 /* 00109 * WNLDELM specifies the namelist delimiter. 00110 */ 00111 #ifdef _UNICOS 00112 void 00113 WNLDELM(_fcd fc) 00114 { 00115 if (_numargs() != sizeof(_fcd)/sizeof(long)) 00116 _lerror(_LELVL_ABORT,FEARGLST,"WNLDELM"); 00117 OUT_CHAR = _getfchar(fc); 00118 } 00119 #else 00120 void 00121 wnldelm_(char *fc, int fclen) 00122 { 00123 OUT_CHAR = _getfchar(_cptofcd(fc,(long)fclen)); 00124 } 00125 #endif 00126 00127 00128 /* 00129 * WNLSEP specifies the namelist seporator. 00130 */ 00131 #ifdef _UNICOS 00132 void 00133 WNLSEP(_fcd fc) 00134 { 00135 if (_numargs() != sizeof(_fcd)/sizeof(long)) 00136 _lerror(_LELVL_ABORT,FEARGLST,"WNLSEP"); 00137 OUT_SEP = _getfchar(fc); 00138 } 00139 #else 00140 void 00141 wnlsep_(char *fc, int fclen) 00142 { 00143 OUT_SEP = _getfchar(_cptofcd(fc,(long)fclen)); 00144 } 00145 #endif 00146 00147 /* 00148 * WNLREP specifies the namelist assignment operator character. 00149 */ 00150 #ifdef _UNICOS 00151 void 00152 WNLREP(_fcd fc) 00153 { 00154 if (_numargs() != sizeof(_fcd)/sizeof(long)) 00155 _lerror(_LELVL_ABORT,FEARGLST,"WNLREP"); 00156 OUT_EQ = _getfchar(fc); 00157 } 00158 #else 00159 void 00160 wnlrep_(char *fc, int fclen) 00161 { 00162 OUT_EQ = _getfchar(_cptofcd(fc,(long)fclen)); 00163 } 00164 #endif 00165 00166 /* 00167 * WNLFLAG specifies the character which is printed in the first column 00168 * of every line. 00169 */ 00170 #ifdef _UNICOS 00171 void 00172 WNLFLAG(_fcd fc) 00173 { 00174 if (_numargs() != sizeof(_fcd)/sizeof(long)) 00175 _lerror(_LELVL_ABORT,FEARGLST,"WNLFLAG"); 00176 OUT_ECHO = _getfchar(fc); 00177 } 00178 #else 00179 void 00180 wnlflag_(char *fc, int fclen) 00181 { 00182 OUT_ECHO = _getfchar(_cptofcd(fc,(long)fclen)); 00183 } 00184 #endif 00185 00186 /* 00187 * WNLLINE specifies the mode for new lines: 00188 * 0 => A new line is not started for every variable. 00189 * 1 => A new line is started for each variable. 00190 */ 00191 #ifdef _UNICOS 00192 void 00193 WNLLINE(_f_int *x) 00194 { 00195 OUT_LINE = (long) *x; 00196 } 00197 #else 00198 void 00199 wnlline_(_f_int *x) 00200 { 00201 OUT_LINE = (long) *x; 00202 } 00203 #endif