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/rnlutil.c 92.1 06/21/99 10:37:55" 00039 00040 #include <liberrno.h> 00041 #include <fortran.h> 00042 #include "fio.h" 00043 #ifndef _UNICOS 00044 #include "rnl90def.h" 00045 #else 00046 #include "rnl.h" 00047 #endif 00048 00049 extern char _getfchar(); 00050 00051 /* 00052 * RNLSKIP determines action if the NAMELIST group encountered is not the 00053 * desired group. 00054 * 00055 * CALL RNLSKIP(mode) 00056 * 00057 * mode >0 Skips the record and issues a message (default) 00058 * =0 Skips the record 00059 * <0 Aborts the job or goes to the optional ERR= branch 00060 */ 00061 #ifdef _UNICOS 00062 void 00063 RNLSKIP(_f_int *mode) 00064 { 00065 _SKP_MESS = *mode; 00066 } 00067 #else 00068 void 00069 rnlskip_(_f_int *mode) 00070 { 00071 _SKP_MESS = (long) *mode; 00072 } 00073 #endif 00074 00075 /* 00076 * RNLTYPE Determines action if type mismatch occurs across equal sign on 00077 * namelist input record. 00078 * 00079 * CALL RNLTYPE(mode) 00080 * 00081 * mode !=0 Converts the constant to the type of the variable (default) 00082 * =0 Aborts the program or goes to the optional ERR= branch 00083 */ 00084 #ifdef _UNICOS 00085 void RNLTYPE(_f_int *mode) 00086 { 00087 _TYP_CONV = *mode; 00088 } 00089 #else 00090 void rnltype_(_f_int *mode) 00091 { 00092 _TYP_CONV = (long) *mode; 00093 } 00094 #endif 00095 00096 /* 00097 * RNLECHO Specifies output unit for NAMELIST error messages and echo lines. 00098 * 00099 * CALL RNLECHO(unum) 00100 * 00101 * unum Output unit to which error messages and echo lines are sent. 00102 * If unum=0, error messages and lines echoed because of an E in 00103 * column 1 go to stdout. 00104 * 00105 * If unum != 0, error messages and input lines are echoed to unum, 00106 * regardless of any echo flags present. If unum=6 or unum=101, 00107 * stdout is implied. 00108 * 00109 */ 00110 #ifdef _UNICOS 00111 void 00112 RNLECHO(_f_int *unum) 00113 { 00114 _OUT_UNIT = *unum; 00115 00116 return; 00117 } 00118 #else 00119 void 00120 rnlecho_(_f_int *unum) 00121 { 00122 _OUT_UNIT = *unum; 00123 00124 return; 00125 } 00126 #endif 00127 00128 /* 00129 * The following routines all have this calling sequence: 00130 * 00131 * CALL RNL____(char, mode) 00132 * 00133 * mode =0 delete character 00134 * !=0 add character 00135 */ 00136 00137 /* 00138 * RNLFLAG adds or removes char from the set of characters that, if found in 00139 * column 1, initiates echoing of the input lines to stdout. 00140 */ 00141 #ifdef _UNICOS 00142 void 00143 RNLFLAG(_fcd chr, _f_int *mode) 00144 { 00145 int thechar; 00146 00147 if (_numargs() != (sizeof(_fcd) + sizeof(long*))/sizeof(long)) 00148 _lerror(_LELVL_ABORT,FEARGLST, "RNLFLAG"); 00149 thechar = _getfchar(chr); 00150 TOGGLE_CHAR(thechar, MRNLFLAG, *mode); 00151 00152 return; 00153 } 00154 #else 00155 void 00156 rnlflag_(char *chr, _f_int *mode, _f_int clen) 00157 { 00158 _f_int thechar; 00159 00160 thechar = (_f_int) _getfchar(_cptofcd(chr, (long)clen)); 00161 TOGGLE_CHAR(thechar, MRNLFLAG, *mode); 00162 00163 return; 00164 } 00165 #endif 00166 00167 /* 00168 * RNLDELM adds or removes char from the set of characters that precede the 00169 * NAMELIST group name and signal end-of-input. 00170 */ 00171 #ifdef _UNICOS 00172 void 00173 RNLDELM(_fcd chr, long *mode) 00174 { 00175 int thechar; 00176 00177 if (_numargs() != (sizeof(_fcd) + sizeof(long*))/sizeof(long)) 00178 _lerror(_LELVL_ABORT,FEARGLST, "RNLDELM"); 00179 thechar = _getfchar(chr); 00180 TOGGLE_CHAR(thechar, MRNLDELIM, *mode); 00181 00182 return; 00183 } 00184 #else 00185 void 00186 rnldelm_(char *chr, _f_int *mode, _f_int clen) 00187 { 00188 _f_int thechar; 00189 00190 thechar = (_f_int) _getfchar(_cptofcd(chr, (long)clen)); 00191 TOGGLE_CHAR(thechar, MRNLDELIM, *mode); 00192 00193 return; 00194 } 00195 #endif 00196 00197 /* 00198 * RNLSEP adds or removes char from the set of characters that must 00199 * follow each constant to act as a separator. 00200 */ 00201 #ifdef _UNICOS 00202 void 00203 RNLSEP(_fcd chr, _f_int *mode) 00204 { 00205 int thechar; 00206 00207 if (_numargs() != (sizeof(_fcd) + sizeof(long*))/sizeof(long)) 00208 _lerror(_LELVL_ABORT,FEARGLST, "RNLSEP"); 00209 thechar = _getfchar(chr); 00210 if (thechar == ' ') 00211 _BLNKSEP = *mode; 00212 TOGGLE_CHAR(thechar, MRNLSEP, *mode); 00213 00214 return; 00215 } 00216 #else 00217 void 00218 rnlsep_(char *chr, _f_int *mode, _f_int clen) 00219 { 00220 int thechar; 00221 00222 thechar = (_f_int) _getfchar(_cptofcd(chr, (long)clen)); 00223 if (thechar == ' ') 00224 _BLNKSEP = (long) *mode; 00225 TOGGLE_CHAR(thechar, MRNLSEP, *mode); 00226 00227 return; 00228 } 00229 #endif 00230 00231 /* 00232 * RNLREP adds or removes char from the set of characters that occur between 00233 * the variable name and the value. 00234 */ 00235 #ifdef _UNICOS 00236 void 00237 RNLREP(_fcd chr, _f_int *mode) 00238 { 00239 int thechar; 00240 00241 if (_numargs() != (sizeof(_fcd) + sizeof(long*))/sizeof(long)) 00242 _lerror(_LELVL_ABORT,FEARGLST, "RNLREP"); 00243 thechar = _getfchar(chr); 00244 TOGGLE_CHAR(thechar, MRNLREP, *mode); 00245 00246 return; 00247 } 00248 #else 00249 void 00250 rnlrep_(char *chr, _f_int *mode, _f_int clen) 00251 { 00252 _f_int thechar; 00253 00254 thechar = (_f_int) _getfchar(_cptofcd(chr, (long)clen)); 00255 TOGGLE_CHAR(thechar, MRNLREP, *mode); 00256 00257 return; 00258 } 00259 #endif 00260 00261 /* 00262 * RNLCOMM adds or removes char from the set of characters that initiate 00263 * trailing comments on a line. 00264 */ 00265 #ifdef _UNICOS 00266 void 00267 RNLCOMM(_fcd chr, _f_int *mode) 00268 { 00269 int thechar; 00270 00271 if (_numargs() != (sizeof(_fcd) + sizeof(long *))/ sizeof(long)) 00272 _lerror(_LELVL_ABORT,FEARGLST, "RNLCOMM"); 00273 thechar = _getfchar(chr); 00274 TOGGLE_CHAR(thechar, MRNLCOMM, *mode); 00275 00276 return; 00277 } 00278 #else 00279 void 00280 rnlcomm_(char *chr, _f_int *mode, _f_int clen) 00281 { 00282 _f_int thechar; 00283 00284 thechar = (_f_int) _getfchar(_cptofcd(chr, (long)clen)); 00285 TOGGLE_CHAR(thechar, MRNLCOMM, *mode); 00286 00287 return; 00288 } 00289 #endif