Doxygen Source Code Documentation
Main Page Alphabetical List Data Structures File List Data Fields Globals Search
lwrite.c
Go to the documentation of this file.00001 #include "f2c.h"
00002 #include "fio.h"
00003 #include "fmt.h"
00004 #include "lio.h"
00005
00006 ftnint L_len;
00007 int f__Aquote;
00008
00009 static VOID
00010 donewrec(Void)
00011 {
00012 if (f__recpos)
00013 (*f__donewrec)();
00014 }
00015
00016 #ifdef KR_headers
00017 t_putc(c)
00018 #else
00019 t_putc(int c)
00020 #endif
00021 {
00022 f__recpos++;
00023 putc(c,f__cf);
00024 return(0);
00025 }
00026 static VOID
00027 #ifdef KR_headers
00028 lwrt_I(n) longint n;
00029 #else
00030 lwrt_I(longint n)
00031 #endif
00032 {
00033 char *p;
00034 int ndigit, sign;
00035
00036 p = f__icvt(n, &ndigit, &sign, 10);
00037 if(f__recpos + ndigit >= L_len)
00038 donewrec();
00039 PUT(' ');
00040 if (sign)
00041 PUT('-');
00042 while(*p)
00043 PUT(*p++);
00044 }
00045 static VOID
00046 #ifdef KR_headers
00047 lwrt_L(n, len) ftnint n; ftnlen len;
00048 #else
00049 lwrt_L(ftnint n, ftnlen len)
00050 #endif
00051 {
00052 if(f__recpos+LLOGW>=L_len)
00053 donewrec();
00054 wrt_L((Uint *)&n,LLOGW, len);
00055 }
00056 static VOID
00057 #ifdef KR_headers
00058 lwrt_A(p,len) char *p; ftnlen len;
00059 #else
00060 lwrt_A(char *p, ftnlen len)
00061 #endif
00062 {
00063 int a;
00064 char *p1, *pe;
00065
00066 a = 0;
00067 pe = p + len;
00068 if (f__Aquote) {
00069 a = 3;
00070 if (len > 1 && p[len-1] == ' ') {
00071 while(--len > 1 && p[len-1] == ' ');
00072 pe = p + len;
00073 }
00074 p1 = p;
00075 while(p1 < pe)
00076 if (*p1++ == '\'')
00077 a++;
00078 }
00079 if(f__recpos+len+a >= L_len)
00080 donewrec();
00081 if (a
00082 #ifndef OMIT_BLANK_CC
00083 || !f__recpos
00084 #endif
00085 )
00086 PUT(' ');
00087 if (a) {
00088 PUT('\'');
00089 while(p < pe) {
00090 if (*p == '\'')
00091 PUT('\'');
00092 PUT(*p++);
00093 }
00094 PUT('\'');
00095 }
00096 else
00097 while(p < pe)
00098 PUT(*p++);
00099 }
00100
00101 static int
00102 #ifdef KR_headers
00103 l_g(buf, n) char *buf; double n;
00104 #else
00105 l_g(char *buf, double n)
00106 #endif
00107 {
00108 #ifdef Old_list_output
00109 doublereal absn;
00110 char *fmt;
00111
00112 absn = n;
00113 if (absn < 0)
00114 absn = -absn;
00115 fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
00116 #ifdef USE_STRLEN
00117 sprintf(buf, fmt, n);
00118 return strlen(buf);
00119 #else
00120 return sprintf(buf, fmt, n);
00121 #endif
00122
00123 #else
00124 register char *b, c, c1;
00125
00126 b = buf;
00127 *b++ = ' ';
00128 if (n < 0) {
00129 *b++ = '-';
00130 n = -n;
00131 }
00132 else
00133 *b++ = ' ';
00134 if (n == 0) {
00135 *b++ = '0';
00136 *b++ = '.';
00137 *b = 0;
00138 goto f__ret;
00139 }
00140 sprintf(b, LGFMT, n);
00141 switch(*b) {
00142 #ifndef WANT_LEAD_0
00143 case '0':
00144 while(b[0] = b[1])
00145 b++;
00146 break;
00147 #endif
00148 case 'i':
00149 case 'I':
00150
00151 case 'n':
00152 case 'N':
00153
00154 while(*++b);
00155 break;
00156
00157 default:
00158
00159 for(;; b++)
00160 switch(*b) {
00161 case 0:
00162 *b++ = '.';
00163 *b = 0;
00164 goto f__ret;
00165 case '.':
00166 while(*++b);
00167 goto f__ret;
00168 case 'E':
00169 for(c1 = '.', c = 'E'; *b = c1;
00170 c1 = c, c = *++b);
00171 goto f__ret;
00172 }
00173 }
00174 f__ret:
00175 return b - buf;
00176 #endif
00177 }
00178
00179 static VOID
00180 #ifdef KR_headers
00181 l_put(s) register char *s;
00182 #else
00183 l_put(register char *s)
00184 #endif
00185 {
00186 #ifdef KR_headers
00187 register int c, (*pn)() = f__putn;
00188 #else
00189 register int c, (*pn)(int) = f__putn;
00190 #endif
00191 while(c = *s++)
00192 (*pn)(c);
00193 }
00194
00195 static VOID
00196 #ifdef KR_headers
00197 lwrt_F(n) double n;
00198 #else
00199 lwrt_F(double n)
00200 #endif
00201 {
00202 char buf[LEFBL];
00203
00204 if(f__recpos + l_g(buf,n) >= L_len)
00205 donewrec();
00206 l_put(buf);
00207 }
00208 static VOID
00209 #ifdef KR_headers
00210 lwrt_C(a,b) double a,b;
00211 #else
00212 lwrt_C(double a, double b)
00213 #endif
00214 {
00215 char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
00216 int al, bl;
00217
00218 al = l_g(bufa, a);
00219 for(ba = bufa; *ba == ' '; ba++)
00220 --al;
00221 bl = l_g(bufb, b) + 1;
00222 for(bb = bufb; *bb == ' '; bb++)
00223 --bl;
00224 if(f__recpos + al + bl + 3 >= L_len)
00225 donewrec();
00226 #ifdef OMIT_BLANK_CC
00227 else
00228 #endif
00229 PUT(' ');
00230 PUT('(');
00231 l_put(ba);
00232 PUT(',');
00233 if (f__recpos + bl >= L_len) {
00234 (*f__donewrec)();
00235 #ifndef OMIT_BLANK_CC
00236 PUT(' ');
00237 #endif
00238 }
00239 l_put(bb);
00240 PUT(')');
00241 }
00242 #ifdef KR_headers
00243 l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
00244 #else
00245 l_write(ftnint *number, char *ptr, ftnlen len, ftnint type)
00246 #endif
00247 {
00248 #define Ptr ((flex *)ptr)
00249 int i;
00250 longint x;
00251 double y,z;
00252 real *xx;
00253 doublereal *yy;
00254 for(i=0;i< *number; i++)
00255 {
00256 switch((int)type)
00257 {
00258 default: f__fatal(204,"unknown type in lio");
00259 case TYINT1:
00260 x = Ptr->flchar;
00261 goto xint;
00262 case TYSHORT:
00263 x=Ptr->flshort;
00264 goto xint;
00265 #ifdef Allow_TYQUAD
00266 case TYQUAD:
00267 x = Ptr->fllongint;
00268 goto xint;
00269 #endif
00270 case TYLONG:
00271 x=Ptr->flint;
00272 xint: lwrt_I(x);
00273 break;
00274 case TYREAL:
00275 y=Ptr->flreal;
00276 goto xfloat;
00277 case TYDREAL:
00278 y=Ptr->fldouble;
00279 xfloat: lwrt_F(y);
00280 break;
00281 case TYCOMPLEX:
00282 xx= &Ptr->flreal;
00283 y = *xx++;
00284 z = *xx;
00285 goto xcomplex;
00286 case TYDCOMPLEX:
00287 yy = &Ptr->fldouble;
00288 y= *yy++;
00289 z = *yy;
00290 xcomplex:
00291 lwrt_C(y,z);
00292 break;
00293 case TYLOGICAL1:
00294 x = Ptr->flchar;
00295 goto xlog;
00296 case TYLOGICAL2:
00297 x = Ptr->flshort;
00298 goto xlog;
00299 case TYLOGICAL:
00300 x = Ptr->flint;
00301 xlog: lwrt_L(Ptr->flint, len);
00302 break;
00303 case TYCHAR:
00304 lwrt_A(ptr,len);
00305 break;
00306 }
00307 ptr += len;
00308 }
00309 return(0);
00310 }
