Open64: osprey/libf/fio/rnlutil.c Source File

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