Open64: osprey/libI77/wrtfmt.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 /* $Header: /proj/osprey/CVS/open64/osprey1.0/libI77/wrtfmt.c,v 1.1.1.1 2005/10/21 19:00:00 marcel Exp $ */
00039 /*  3.0 SID # 1.2 */
00040 /* who  ref.    date    description     */
00041 /* sjc  #2113 4Dec87    coding error kills dp exponent    */
00042 
00043 #include <cmplrs/fio.h>
00044 #include <ctype.h>
00045 #include <string.h>
00046 #include "fmt.h"
00047 #include "ecvt_mp.h"
00048 #include "err.h"
00049 #include "wrtfmt.h"
00050 #include "fmtlib.h"
00051 #include "lio.h"
00052 #include "wsfe.h"
00053 #include "dfe.h"
00054 #include "typecheck.h"
00055 #include "../include/cmplrs/f_errno.h"
00056 
00057 extern int fmt_check;
00058 
00059 #include "ctype.h"
00060 #if defined(_SYSTYPE_SVR4)
00061 #define fp_class_d _fp_class_d
00062 #endif
00063 /* Fix BN 8559  ---ravi---    10/28/91 */
00064 #include <fp_class.h>
00065 
00066 static double exp10_array[41] = { 1e-20, 1e-19, 1e-18, 1e-17, 1e-16, 1e-15, 1e-14, 1e-13, 1e-12, 1e-11,
00067           1e-10, 1e-9, 1e-8, 1e-7, 1e-6, 1e-5, 1e-4, 1e-3, 1e-2, 1e-1,
00068           1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9, 1e10,
00069           1e11, 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19, 1e20 };
00070 
00071 
00072 static double roundup_array[22] = { .5e-20, .5e-20, .5e-19, .5e-18, .5e-17, .5e-16, .5e-15,
00073             .5e-14, .5e-13, .5e-12, .5e-11, .5e-10, .5e-9, .5e-8, .5e-7,
00074             .5e-6, .5e-5, .5e-4, .5e-3, .5e-2, .5e-1, .5e0 };
00075 
00076 static int dmax = 20; /* maximum index for exp10 and roundup macros */
00077 #define exp10(e) exp10_array[(e)+dmax]
00078 #define roundup(e) roundup_array[(e)+dmax+1]
00079 
00080 static int exceed_length(unit *, int);
00081 
00082 static int mv_cur (unit *ftnunit)
00083 {       /* buggy, could move off front of
00084          * record */
00085    int result;
00086    if (ftnunit->f77cursor > 0) {
00087       if (result = PUT (ftnunit->f77cursor, '\0', NULL))
00088     return(result);
00089       ftnunit->f77cursor = 0;
00090    }
00091    if (ftnunit->f77cursor < 0) {
00092       if (ftnunit->f77cursor < -ftnunit->f77recpos)
00093    ftnunit->f77cursor = -ftnunit->f77recpos;
00094       for (; ftnunit->f77cursor < 0; ftnunit->f77cursor++)
00095    if ((*ftnunit->f77ungetn) (ftnunit, 0) < 0) {
00096       err(CILISTERR, 106, "fmt");
00097    }
00098    }
00099    return (0);
00100 }
00101 
00102 int wrt_I (unit *ftnunit, uinteger *n, int w, ftnlen len)
00103 {
00104    int             ndigit, sign, spare;
00105    int             x;
00106    char           *ans;
00107    char      buf[MAXOCTLENGTH];
00108 
00109    if (len == sizeof (short))
00110       x = n->is;
00111    else if (len == sizeof (char))
00112       x = n->ic;
00113    else if (len == sizeof (ftnll))
00114       return (wrt_LL (ftnunit, n, w));
00115    else
00116       x = n->ii;
00117    if (w == 0)
00118       w = len < 4 ? 7 : 12;
00119    if (exceed_length(ftnunit, w)) return(110);
00120    ans = icvt (x, &ndigit, &sign, buf);
00121    spare = w - ndigit;
00122    if (sign || ftnunit->f77cplus)
00123       spare--;
00124    if (spare < 0)
00125       PUT (w, '*', NULL);
00126    else {
00127       PUT (spare, ' ', NULL);
00128       if (sign)
00129    PUT (1, '-', NULL);
00130       else if (ftnunit->f77cplus)
00131    PUT (1, '+', NULL);
00132       PUT (ndigit, 0, ans);
00133    }
00134    return (0);
00135 }
00136 
00137 int wrt_LL (unit *ftnunit, uinteger *n, int w)
00138 {
00139    int             ndigit, sign, spare;
00140    ftnll           x;
00141    char           *ans;
00142    char      buf[MAXOCTLENGTH];
00143 
00144    x = n->ill;
00145    if (w == 0)
00146       w = 21;
00147    if (exceed_length(ftnunit, w)) return(110);
00148    ans = llcvt (x, &ndigit, &sign, buf);
00149    spare = w - ndigit;
00150    if (sign || ftnunit->f77cplus)
00151       spare--;
00152    if (spare < 0)
00153       PUT (w, '*', NULL);
00154    else {
00155       PUT (spare, ' ', NULL);
00156       if (sign)
00157    PUT (1, '-', NULL);
00158       else if (ftnunit->f77cplus)
00159    PUT (1, '+', NULL);
00160       PUT (ndigit, 0, ans);
00161    }
00162    return (0);
00163 }
00164 
00165 static int wrt_OZ (unit *ftnunit, unsigned char *n, int w, ftnlen len, int base)
00166 {
00167    char           *ans;
00168    int             ndigit, spare, shift;
00169    char      buf[MAXOCTLENGTH];
00170 
00171    shift = base == 8 ? 3 : 4;
00172    if (w == 0)
00173       w = len < 4 ? 7 : (len < 8 ? 12 :
00174         (len > 8 ? (len * 8 + shift - 1) / shift : 23));
00175    if (exceed_length(ftnunit, w)) return(110);
00176    ans = ozcvt (n, len, &ndigit, base, buf);
00177    spare = w - ndigit;
00178    if (spare < 0)
00179       PUT (w, '*', NULL);
00180    else {
00181       PUT (spare, ' ', NULL);
00182       PUT (ndigit, 0, ans);
00183    }
00184    return (0);
00185 }
00186 
00187 static int wrt_OZM (unit *ftnunit, unsigned char *n, int w, int m, ftnlen len, int base)
00188 {
00189    char           *ans;
00190    int             ndigit, spare;
00191    char      buf[MAXOCTLENGTH];
00192 
00193    ans = ozcvt (n, len, &ndigit, base, buf);
00194    if (ndigit >= m)
00195       spare = w - ndigit;
00196    else
00197       spare = w - m;
00198    if (exceed_length(ftnunit, w)) return(110);
00199 
00200    if (spare < 0)
00201       PUT (w, '*', NULL);
00202    else {
00203       PUT (spare, ' ', NULL);
00204       if (m > ndigit)
00205    PUT (m - ndigit, '0', NULL);
00206       PUT (ndigit, 0, ans);
00207    }
00208    return (0);
00209 }
00210 
00211 static int wrt_LLM (unit *ftnunit, uinteger *n, int w, int m)
00212 {
00213    int             ndigit, sign, spare, xsign;
00214    ftnll           x;
00215    char           *ans;
00216    char      buf[MAXOCTLENGTH];
00217 
00218    x = n->ill;
00219    if (exceed_length(ftnunit, w)) return(110);
00220    ans = llcvt (x, &ndigit, &sign, buf);
00221    if (sign || ftnunit->f77cplus)
00222       xsign = 1;
00223    else
00224       xsign = 0;
00225    if (ndigit + xsign > w || m + xsign > w) {
00226       PUT (w, '*', NULL);
00227       return (0);
00228    }
00229    if (x == 0 && m == 0) {
00230       PUT (w, ' ', NULL);
00231       return (0);
00232    }
00233    if (ndigit >= m)
00234       spare = w - ndigit - xsign;
00235    else
00236       spare = w - m - xsign;
00237    PUT (spare, ' ', NULL);
00238    if (sign)
00239       PUT (1, '-', NULL);
00240    else if (ftnunit->f77cplus)
00241       PUT (1, '+', NULL);
00242    if (m > ndigit)
00243       PUT (m - ndigit, '0', NULL);
00244    PUT (ndigit, 0, ans);
00245    return (0);
00246 }
00247 static int wrt_IM (unit *ftnunit, uinteger *n, int w, int m, ftnlen len)
00248 {
00249    int             ndigit, sign, spare, xsign;
00250    int             x;
00251    char           *ans;
00252    char      buf[MAXOCTLENGTH];
00253 
00254    if (exceed_length(ftnunit, w)) return(110);
00255    if (sizeof (short) == len)
00256       x = n->is;
00257    else if (len == sizeof (char))
00258       x = n->ic;
00259    else if (len == sizeof (ftnll))
00260       return (wrt_LLM (ftnunit, n, w, m));
00261    else
00262       x = n->ii;
00263    ans = icvt (x, &ndigit, &sign, buf);
00264    if (sign || ftnunit->f77cplus)
00265       xsign = 1;
00266    else
00267       xsign = 0;
00268    if (ndigit + xsign > w || m + xsign > w) {
00269       PUT (w, '*', NULL);
00270       return (0);
00271    }
00272    if (x == 0 && m == 0) {
00273       PUT (w, ' ', NULL);
00274       return (0);
00275    }
00276    if (ndigit >= m)
00277       spare = w - ndigit - xsign;
00278    else
00279       spare = w - m - xsign;
00280    PUT (spare, ' ', NULL);
00281    if (sign)
00282       PUT (1, '-', NULL);
00283    else if (ftnunit->f77cplus)
00284       PUT (1, '+', NULL);
00285    if (m > ndigit)
00286       PUT (m - ndigit, '0', NULL);
00287    PUT (ndigit, 0, ans);
00288    return (0);
00289 }
00290 
00291 
00292 static int wrt_AP (unit *ftnunit, char *s)
00293 {
00294    char           quote;
00295    int result;
00296 
00297    if (result = mv_cur (ftnunit))
00298       return (result);
00299    quote = *s++;
00300    for (; *s && !result; s++) {
00301       if (*s != quote)
00302    result = PUT (1, *s, NULL);
00303       else if (*++s == quote)
00304    result = PUT (1, quote, NULL);
00305       else
00306    return (0);
00307    }
00308    return (result);
00309 }
00310 
00311 static int wrt_H (unit *ftnunit, int a, char *s)
00312 {
00313    int result;
00314 
00315    if (result = mv_cur (ftnunit))
00316       return (result);
00317    result = PUT (a, 0, s);
00318    return(result);
00319 }
00320 
00321 int wrt_L (unit *ftnunit, uinteger *n, int len, ftnlen sz)
00322 {
00323    int             i;
00324    ftnll           x;
00325 
00326    if (sizeof (short) == sz)
00327       x = n->is;
00328    else if (sz == sizeof (char))
00329       x = n->ic;
00330    else if (sz == sizeof (ftnll))
00331       x = n->ill;
00332    else
00333       x = n->ii;
00334    len = len ? len : 2;
00335    for (i = 0; i < len - 1; i++)
00336       PUT (1, ' ', NULL);
00337    if (x)
00338       return(PUT (1, 'T', NULL));
00339    else
00340       return(PUT (1, 'F', NULL));
00341 }
00342 
00343 static int wrt_A (unit *ftnunit, char *p, ftnlen len)
00344 {
00345    return(PUT (len, 0, p));
00346 }
00347 
00348 static int wrt_AW (unit *ftnunit, char *p, int w, ftnlen len)
00349 {
00350    if (exceed_length(ftnunit, w)) return(110);
00351    if (w > len) {
00352       PUT (w - len, ' ', NULL);
00353       PUT (len, 0, p);
00354    } else
00355       PUT (w, 0, p);
00356    return (0);
00357 }
00358 
00359 static int 
00360 wrt_E (unit *ftnunit, ufloat *p, int w, int d, int e, ftnlen len, char symbol, flag doblank)
00361 {
00362    char           *s = NULL;
00363    int             dp, absdp, sign, i, delta, pow10, leading0;
00364    double          dd;
00365    char     buffer[100];
00366 
00367    if (len == sizeof (float))
00368       dd = p->pf;
00369    else
00370       dd = p->pd;
00371    if (w == 0) {
00372       if (len == 4) {
00373    w = 15;
00374    d = 7;
00375       } else {
00376    w = 25;
00377    d = 16;
00378       }
00379       e = 2;
00380    }
00381    if (exceed_length(ftnunit, w)) return(110);
00382    dp = ftnunit->f77scale > 0 ? d + 1 : d + ftnunit->f77scale;
00383 /* 
00384  * BN 8559 . There is a problem with ecvt ( from libc ) and if the number dd
00385  * passed to it is Infinity -ve or positive and dp ( the length of the
00386  * string passed back ) is less than 8, then the string "Infinity" gets
00387  * truncated. Rather than try to fix this in ecvt  , have akludge here to
00388  * take care of the problem. Test to see if dd is inf. and if it is set the
00389  * string s = "infinity"
00390  * ---ravi---   10/28/91
00391   
00392   if ( dp > 0 ) s=ecvt_mp( dd ,dp,&dp,&sign, buffer);
00393   
00394 */
00395    if (dp > 0) {
00396       s = ecvt_mp (dd, dp, &dp, &sign, buffer);
00397       if (fp_class_d (dd) == FP_POS_INF)
00398    s = "Inf";
00399       else if (fp_class_d (dd) == FP_NEG_INF)
00400    s = "-Inf";
00401 
00402    }
00403 /* Fix BN 11222.
00404  * Make sure s is not NULL before dereferencing it.
00405  * ---ravi---1/27/92
00406  */
00407    /* if (!isdigit(*s)) { *//* just print Infinity, Nan, etc. */
00408    if (s && !isdigit (*s)) {  /* just print Infinity, Nan, etc. */
00409       PUT ((i = (int) strlen (s)), 0, s);
00410       if (doblank && w > i)
00411    PUT (w - i, ' ', NULL);/* pad to proper width */
00412    } else {     /* do the normal thing */
00413       if (dd != 0) {    /* sjc #2113 */
00414    dp -= ftnunit->f77scale;
00415    absdp = dp < 0 ? -dp : dp;
00416       } else
00417    absdp = dp = 0;
00418       delta = e ? e + 3 : 5;
00419       if (sign || ftnunit->f77cplus)
00420    delta++;   /* AGC 10/29/86 */
00421       if (ftnunit->f77scale > 0)
00422    delta++;
00423       if ((w > delta + d) && (ftnunit->f77scale <= 0)) {
00424    delta++;
00425    leading0 = 1;
00426       } else
00427    leading0 = 0;
00428       if ((w < delta + d) 
00429      || (e == 1 && absdp > 9) 
00430      || (e == 2 && absdp > 99) 
00431      || (ftnunit->f77scale <= 0 && ftnunit->f77scale <= -d) 
00432      || (ftnunit->f77scale > 0 && ftnunit->f77scale > d + 1)) {
00433    PUT (w, '*', NULL);
00434    return (0);
00435       }
00436       if (doblank && w > (delta + d))
00437    PUT (w - (delta + d), ' ', NULL);
00438       if (sign)
00439    PUT (1, (char) (dd==0 ? ' ' : '-'), NULL);
00440       else if (ftnunit->f77cplus)
00441    PUT (1, '+', NULL);
00442       if (ftnunit->f77scale <= 0) {
00443    if (leading0)
00444       PUT (1, '0', NULL);
00445    PUT (1, '.', NULL);
00446    PUT (-ftnunit->f77scale, '0', NULL);
00447    if ((d + ftnunit->f77scale) > 0)
00448       PUT (d + ftnunit->f77scale, 0, s);
00449       } else {
00450    PUT (ftnunit->f77scale, 0, s);
00451    PUT (1, '.', NULL);
00452 /* 6/26/89
00453  * fix bug 4547
00454  */
00455    if (d >= ftnunit->f77scale)
00456       PUT (d - ftnunit->f77scale + 1, 0, s + ftnunit->f77scale);
00457       }
00458       if ((e > 0) || (absdp < 100))
00459    PUT (1, symbol, NULL);
00460       PUT (1, (char) (dp < 0 ? '-' : '+'), NULL);
00461       if (!e) {
00462    /* For the common case this is much faster than the general
00463       algorithm
00464    */
00465          if (absdp > 99.0) {
00466        PUT (1, (char) ((i = absdp / 1e2 ) + '0'), NULL);
00467        absdp -= i * 1e2;
00468          }
00469          PUT (1, (char) ((i = absdp / 1e1)  + '0'), NULL);
00470          absdp -= i * 1e1;
00471          PUT (1, (char) ((i = absdp) + '0'), NULL);
00472       }
00473       else {
00474          for (pow10 = 1, i = e; --i; pow10 *= 10);
00475          while (e--) {
00476       PUT (1, (char) ((i = absdp / pow10) + '0'), NULL);
00477       absdp -= i * pow10;
00478       pow10 /= 10;
00479          }
00480       }
00481 
00482    }
00483    return (0);
00484 }
00485 
00486 static int 
00487 wrt_EQ (unit *ftnunit, ufloat *p, int w, int d, int e, ftnlen notused_len, char symbol, flag doblank)
00488 {
00489    char           *s = NULL;
00490    int             dp, absdp, sign, i, delta, pow10, leading0;
00491    long double     dd;
00492    char     buffer[100];
00493 
00494    dd = p->pld;
00495    if (w == 0) {
00496       w = 40;
00497       d = 31;
00498       e = 2;
00499    }
00500    if (exceed_length(ftnunit, w)) return(110);
00501    dp = ftnunit->f77scale > 0 ? d + 1 : d + ftnunit->f77scale;
00502    if (dp > 0) {
00503       s = qecvt_mp (dd, dp, &dp, &sign, buffer);
00504       if (fp_class_d (dd) == FP_POS_INF)
00505    s = "Inf";
00506       else if (fp_class_d (dd) == FP_NEG_INF)
00507    s = "-Inf";
00508 
00509    }
00510    if (s && !isdigit (*s)) {  /* just print Infinity, Nan, etc. */
00511       PUT ((i = (int) strlen (s)), 0, s);
00512       if (doblank && w > i)
00513    PUT (w - i, ' ', NULL);/* pad to proper width */
00514    } else {     /* do the normal thing */
00515       if (dd != 0) {    /* sjc #2113 */
00516    dp -= ftnunit->f77scale;
00517    absdp = dp < 0 ? -dp : dp;
00518       } else
00519    absdp = dp = 0;
00520       delta = e ? e + 3 : 5;
00521       if (sign || ftnunit->f77cplus)
00522    delta++;   /* AGC 10/29/86 */
00523       if (ftnunit->f77scale > 0)
00524    delta++;
00525       if ((w > delta + d) && (ftnunit->f77scale <= 0)) {
00526    delta++;
00527    leading0 = 1;
00528       } else
00529    leading0 = 0;
00530       if ((w < delta + d) 
00531     || (e == 1 && absdp > 9) 
00532     || (e == 2 && absdp > 99) 
00533     || (ftnunit->f77scale <= 0 && ftnunit->f77scale <= -d) 
00534     || (ftnunit->f77scale > 0 && ftnunit->f77scale > d + 1)) {
00535    PUT (w, '*', NULL);
00536    return (0);
00537       }
00538       if (doblank && w > (delta + d))
00539    PUT (w - (delta + d), ' ', NULL);
00540       if (sign)
00541    PUT (1, (char) (dd==0 ? ' ' : '-'), NULL);
00542       else if (ftnunit->f77cplus)
00543    PUT (1, '+', NULL);
00544       if (ftnunit->f77scale <= 0) {
00545    if (leading0)
00546       PUT (1, '0', NULL);
00547    PUT (1, '.', NULL);
00548    PUT (-ftnunit->f77scale, '0', NULL);
00549    if ((d + ftnunit->f77scale) > 0)
00550       PUT (d + ftnunit->f77scale, 0, s);
00551       } else {
00552    PUT (ftnunit->f77scale, 0, s);
00553    PUT (1, '.', NULL);
00554 /* 6/26/89
00555  * fix bug 4547
00556  */
00557    if (d >= ftnunit->f77scale)
00558       PUT (d - ftnunit->f77scale + 1, 0, s + ftnunit->f77scale);
00559       }
00560       if ((e > 0) || (absdp < 100))
00561    PUT (1, symbol, NULL);
00562       PUT (1, (char) (dp < 0 ? '-' : '+'), NULL);
00563       if (!e)
00564    e = absdp > 99 ? 3 : 2;
00565       for (pow10 = 1, i = e; --i; pow10 *= 10);
00566       while (e--) {
00567    PUT (1, (char) ((i = absdp / pow10) + '0'), NULL);
00568    absdp -= i * pow10;
00569    pow10 /= 10;
00570       }
00571    }
00572    return (0);
00573 }
00574 
00575 #ifdef I90
00576 static int wrt_BM (unit *ftnunit, unsigned char *n, int w, int m, ftnlen len)
00577 {
00578    char           *ans;
00579    int             ndigit, spare;
00580    char      buf[MAXOCTLENGTH*3+1];
00581 
00582    if (exceed_length(ftnunit, w)) return(110);
00583 
00584    ans = bcvt (n, len, &ndigit, buf);
00585 
00586    if (ndigit > m )
00587       spare = w - ndigit;
00588    else
00589       spare = w - m;
00590 
00591    if (spare < 0)
00592       PUT (w, '*', NULL);
00593    else {
00594       if ( spare > 0 ) PUT (spare, ' ', NULL);
00595       if ( m > ndigit ) PUT (m - ndigit, '0', NULL);
00596       if ( ndigit > 0 ) PUT (ndigit, 0, ans);
00597    }
00598    return (0);
00599 }
00600 
00601 static int wrt_EN (unit *ftnunit, ufloat *p, int w, int d, int e, ftnlen len, char symbol, flag doblank)
00602 {
00603    char           *s = NULL;
00604    int             dp, absdp, sign, i;
00605    double          dd;
00606    char     buffer[100];
00607    int       left_digits = 3; /* maximum value */
00608    int       spaces_needed;
00609 
00610    if (len == sizeof (float))
00611       dd = p->pf;
00612    else
00613       dd = p->pd;
00614 
00615    dp = d + left_digits;
00616 
00617    if (dp > 0) {
00618       s = ecvt_mp (dd, dp, &dp, &sign, buffer);
00619       if (fp_class_d (dd) == FP_POS_INF)
00620    s = "Inf";
00621       else if (fp_class_d (dd) == FP_NEG_INF)
00622    s = "-Inf";
00623    }
00624 
00625    if (s && !isdigit (*s)) {  /* just print Infinity, Nan, etc. */
00626       PUT ((i = (int) strlen (s)), 0, s);
00627       if (doblank && w > i) PUT (w - i, ' ', NULL);/* pad to proper width */
00628 
00629    } else {     /* do the normal thing */
00630 
00631       if (dd != 0) {
00632    if ( dp > 0 ) {
00633             left_digits = (dp-1) % 3 + 1;
00634    } else {
00635             left_digits = 3 + dp % 3;
00636    }
00637    if ( left_digits < 3 ) { /* maybe roundoff error */
00638       dp = d + left_digits; /* try again with smaller number of significant digits */
00639       s = ecvt_mp (dd, dp, &dp, &sign, buffer);
00640       if ( dp > 0 ) {
00641     left_digits = (dp-1) % 3 + 1;
00642       } else {
00643     left_digits = 3 + dp % 3;
00644       }
00645    }
00646          dp = dp - left_digits;  /* interpret string s as   x.xxxxxxxE+3n */
00647                 /* or  xx.xxxxxxxE+3n */
00648                 /* or xxx.xxxxxxxE+3n */
00649       } else {
00650    dp = 0;
00651    left_digits = 1;
00652       }
00653       if (dd != 0) {    /* sjc #2113 */
00654    dp -= ftnunit->f77scale;
00655    absdp = dp < 0 ? -dp : dp;
00656       } else
00657    absdp = dp = 0;
00658 
00659       if ( e == 0 && absdp > 999 ) return(100);
00660 
00661       spaces_needed = e ? e + 3 : 5;
00662 
00663       if (sign || ftnunit->f77cplus) spaces_needed++;
00664 
00665       spaces_needed += d + left_digits;
00666 
00667       if ((w < spaces_needed) 
00668     || (e == 1 && absdp > 9) 
00669     || (e == 2 && absdp > 99)) {
00670    PUT (w, '*', NULL);
00671    return (0);
00672       }
00673 
00674       if (doblank && w > spaces_needed)
00675    PUT (w - spaces_needed, ' ', NULL);
00676 
00677       if (sign)
00678    PUT (1, (char) (dd==0 ? ' ' : '-'), NULL);
00679       else if (ftnunit->f77cplus)
00680    PUT (1, '+', NULL);
00681 
00682       PUT (left_digits, 0, s);
00683       PUT (1, '.', NULL);
00684       PUT (d, 0, &s[left_digits]);
00685 
00686       if ((e > 0) || (absdp < 100)) PUT (1, symbol, NULL);
00687 
00688       PUT (1, (char) (dp < 0 ? '-' : '+'), NULL);
00689 
00690       if (!e) e = absdp > 99 ? 3 : 2;
00691 
00692       while (e--) {
00693    PUT (1, (char) ((i = absdp / exp10(e)) + '0'), NULL);
00694    absdp -= i * exp10(e);
00695       }
00696 
00697    }
00698    return (0);
00699 }
00700 
00701 static int wrt_ENQ (unit *ftnunit, ufloat *p, int w, int d, int e, ftnlen notused_len, char symbol, flag doblank)
00702 {
00703    char           *s = NULL;
00704    int             dp, absdp, sign, i;
00705    long double     dd;
00706    char     buffer[100];
00707    int       left_digits = 3; /* maximum value */
00708    int       spaces_needed;
00709 
00710    dd = p->pld;
00711 
00712    dp = d + left_digits;
00713 
00714    if (dp > 0) {
00715       s = qecvt_mp (dd, dp, &dp, &sign, buffer);
00716       if (fp_class_d (dd) == FP_POS_INF)
00717    s = "Inf";
00718       else if (fp_class_d (dd) == FP_NEG_INF)
00719    s = "-Inf";
00720    }
00721 
00722    if (s && !isdigit (*s)) {  /* just print Infinity, Nan, etc. */
00723       PUT ((i = (int) strlen (s)), 0, s);
00724       if (doblank && w > i)
00725    PUT (w - i, ' ', NULL);/* pad to proper width */
00726 
00727    } else {     /* do the normal thing */
00728 
00729       if (dd != 0) {
00730    if ( dp > 0 ) {
00731             left_digits = (dp-1) % 3 + 1;
00732    } else {
00733             left_digits = 3 + dp % 3;
00734    }
00735    if ( left_digits < 3 ) { /* maybe roundoff error */
00736       dp = d + left_digits; /* try again with smaller number of significant digits */
00737       s = qecvt_mp (dd, dp, &dp, &sign, buffer);
00738       if ( dp > 0 ) {
00739     left_digits = (dp-1) % 3 + 1;
00740       } else {
00741     left_digits = 3 + dp % 3;
00742       }
00743    }
00744          dp = dp - left_digits;  /* interpret string s as   x.xxxxxxxE+3n */
00745                 /* or  xx.xxxxxxxE+3n */
00746                 /* or xxx.xxxxxxxE+3n */
00747       } else {
00748    dp = 0;
00749    left_digits = 1;
00750       }
00751       if (dd != 0) {    /* sjc #2113 */
00752    dp -= ftnunit->f77scale;
00753    absdp = dp < 0 ? -dp : dp;
00754       } else
00755    absdp = dp = 0;
00756 
00757       if ( e == 0 && absdp > 999 ) return(100);
00758 
00759       spaces_needed = e ? e + 3 : 5;
00760 
00761       if (sign || ftnunit->f77cplus) spaces_needed++;
00762 
00763       spaces_needed += d + left_digits;
00764 
00765       if ((w < spaces_needed) 
00766     || (e == 1 && absdp > 9) 
00767     || (e == 2 && absdp > 99)) {
00768    PUT (w, '*', NULL);
00769    return (0);
00770       }
00771 
00772       if (doblank && w > spaces_needed )
00773    PUT (w - spaces_needed, ' ', NULL);
00774 
00775       if (sign)
00776    PUT (1, (char) (dd==0 ? ' ' : '-'), NULL);
00777       else if (ftnunit->f77cplus)
00778    PUT (1, '+', NULL);
00779 
00780       PUT (left_digits, 0, s);
00781       PUT (1, '.', NULL);
00782       PUT (d, 0, &s[left_digits]);
00783 
00784       if ((e > 0) || (absdp < 100)) PUT (1, symbol, NULL);
00785 
00786       PUT (1, (char) (dp < 0 ? '-' : '+'), NULL);
00787 
00788       if (!e) e = absdp > 99 ? 3 : 2;
00789 
00790       while (e--) {
00791    PUT (1, (char) ((i = absdp / exp10(e)) + '0'), NULL);
00792    absdp -= i * exp10(e);
00793       }
00794 
00795    }
00796    return (0);
00797 }
00798 
00799 static int wrt_ES (unit *ftnunit, ufloat *p, int w, int d, int e, ftnlen len, char symbol, flag doblank)
00800 {
00801    char           *s = NULL;
00802    int             dp, absdp, sign, i;
00803    double          dd;
00804    char     buffer[100];
00805    int       left_digits = 1; /* maximum value */
00806    int             spaces_needed;
00807 
00808    if (len == sizeof (float))
00809       dd = p->pf;
00810    else
00811       dd = p->pd;
00812 
00813    dp = d + left_digits;
00814 
00815    if (dp > 0) {
00816       s = ecvt_mp (dd, dp, &dp, &sign, buffer);
00817       if (fp_class_d (dd) == FP_POS_INF)
00818    s = "Inf";
00819       else if (fp_class_d (dd) == FP_NEG_INF)
00820    s = "-Inf";
00821    }
00822 
00823    if (s && !isdigit (*s)) {  /* just print Infinity, Nan, etc. */
00824       PUT ((i = (int) strlen (s)), 0, s);
00825       if (doblank && w > i) PUT (w - i, ' ', NULL);/* pad to proper width */
00826 
00827    } else {     /* do the normal thing */
00828 
00829       dp = dp - left_digits;  /* interpret string s as x.xxxxxxx */
00830       if (dd != 0) {    /* sjc #2113 */
00831    dp -= ftnunit->f77scale;
00832    absdp = dp < 0 ? -dp : dp;
00833       } else
00834    absdp = dp = 0;
00835 
00836       if ( e == 0 && absdp > 999 ) return(100);
00837 
00838       spaces_needed = e ? e + 3 : 5;
00839 
00840       if (sign || ftnunit->f77cplus) spaces_needed++;
00841 
00842       spaces_needed += d + left_digits;
00843 
00844       if ((w < spaces_needed) 
00845     || (e == 1 && absdp > 9) 
00846     || (e == 2 && absdp > 99)) {
00847    PUT (w, '*', NULL);
00848    return (0);
00849       }
00850 
00851       if (doblank && w > spaces_needed)
00852    PUT (w - spaces_needed, ' ', NULL);
00853 
00854       if (sign)
00855    PUT (1, (char) (dd==0 ? ' ' : '-'), NULL);
00856       else if (ftnunit->f77cplus)
00857    PUT (1, '+', NULL);
00858 
00859       PUT (left_digits, 0, s);
00860       PUT (1, '.', NULL);
00861       PUT (d, 0, &s[left_digits]);
00862 
00863       if ((e > 0) || (absdp < 100)) PUT (1, symbol, NULL);
00864 
00865       PUT (1, (char) (dp < 0 ? '-' : '+'), NULL);
00866 
00867       if (!e) e = absdp > 99 ? 3 : 2;
00868 
00869       while (e--) {
00870    PUT (1, (char) ((i = absdp / exp10(e)) + '0'), NULL);
00871    absdp -= i * exp10(e);
00872       }
00873 
00874    }
00875    return (0);
00876 }
00877 
00878 static int wrt_ESQ (unit *ftnunit, ufloat *p, int w, int d, int e, ftnlen notused_len, char symbol, flag doblank)
00879 {
00880    char           *s = NULL;
00881    int             dp, absdp, sign, i;
00882    long double     dd;
00883    char     buffer[100];
00884    int       left_digits = 1; /* maximum value */
00885    int             spaces_needed;
00886 
00887    dd = p->pld;
00888 
00889    dp = d + left_digits;
00890 
00891    if (dp > 0) {
00892       s = qecvt_mp (dd, dp, &dp, &sign, buffer);
00893       if (fp_class_d (dd) == FP_POS_INF)
00894    s = "Inf";
00895       else if (fp_class_d (dd) == FP_NEG_INF)
00896    s = "-Inf";
00897    }
00898 
00899    if (s && !isdigit (*s)) {  /* just print Infinity, Nan, etc. */
00900       PUT ((i = (int) strlen (s)), 0, s);
00901       if (doblank && w > i)
00902    PUT (w - i, ' ', NULL);/* pad to proper width */
00903 
00904    } else {     /* do the normal thing */
00905 
00906       dp = dp - left_digits;  /* interpret string s as x.xxxxxxx */
00907       if (dd != 0) {    /* sjc #2113 */
00908    dp -= ftnunit->f77scale;
00909    absdp = dp < 0 ? -dp : dp;
00910       } else
00911    absdp = dp = 0;
00912 
00913       if ( e == 0 && absdp > 999 ) return(100);
00914 
00915       spaces_needed = e ? e + 3 : 5;
00916 
00917       if (sign || ftnunit->f77cplus) spaces_needed++;
00918 
00919       spaces_needed += d + left_digits;
00920 
00921       if ((w < spaces_needed) 
00922     || (e == 1 && absdp > 9) 
00923     || (e == 2 && absdp > 99)) {
00924    PUT (w, '*', NULL);
00925    return (0);
00926       }
00927 
00928       if (doblank && w > spaces_needed)
00929    PUT (w - spaces_needed, ' ', NULL);
00930 
00931       if (sign)
00932    PUT (1, (char) (dd==0 ? ' ' : '-'), NULL);
00933       else if (ftnunit->f77cplus)
00934    PUT (1, '+', NULL);
00935 
00936       PUT (1, s[0],  NULL);
00937       PUT (1,  '.',  NULL);
00938       PUT (d,    0, &s[1]);
00939 
00940       if ((e > 0) || (absdp < 100)) PUT (1, symbol, NULL);
00941 
00942       PUT (1, (char) (dp < 0 ? '-' : '+'), NULL);
00943 
00944       if (!e) e = absdp > 99 ? 3 : 2;
00945 
00946       while (e--) {
00947    PUT (1, (char) ((i = absdp / exp10(e)) + '0'), NULL);
00948    absdp -= i * exp10(e);
00949       }
00950 
00951    }
00952    return (0);
00953 }
00954 #endif
00955 
00956 static int 
00957 wrt_F (unit *ftnunit, ufloat *p, int w, int d, ftnlen len, flag doblank)
00958 {
00959    int             i, delta, dp, sign, n, leading0;
00960    double          x;
00961    /* extern FILE *debugfile; */
00962    char     buffer[100];
00963    char           *s;
00964 
00965    x = (len == sizeof (float) ? p->pf : p->pd);
00966    if (w == 0) {
00967       if (len == 4) {
00968    w = 15;
00969    d = 7;
00970       } else {
00971    w = 25;
00972    d = 16;
00973       }
00974    }
00975    if (exceed_length(ftnunit, w)) return(110);
00976    if (ftnunit->f77scale) {
00977       if (ftnunit->f77scale > 0)
00978    for (i = 0; i < ftnunit->f77scale; i++)
00979       x *= 10;
00980       else
00981    for (i = 0; i < -ftnunit->f77scale; i++)
00982       x /= 10;
00983    }
00984    s = fcvt_mp (x, d, &dp, &sign, buffer);
00985 /* fprintf(debugfile, "Writing %s for thread %d\n", s, mp_my_threadnum_()); */
00986 /* Fix BN 11269. 
00987  * If the the string s does not contain a digit as the first character , then
00988  * the result is either "Infinity", or "NaN" . Print this out and do not
00989  * process the string according format specification.
00990  * ---ravi---
00991  */
00992 /* Fix BN 11584. There is a possibility that d may be 0 in which case the string
00993  * s is empty and then the above test suceeds which should not happen. So add
00994  * the conditon that d should be non-zero.
00995  * ---ravi---1/29/92
00996  */
00997    if (!isdigit (*s) && strlen (s)) { /* just print Infinity, Nan,
00998            * etc. */
00999       PUT ((i = (int) strlen (s)), 0, s);
01000       if (doblank && w > i)
01001    PUT (w - i, ' ', NULL);/* pad to proper width */
01002    } else {
01003       if (-dp >= d)
01004    sign = 0;
01005       if (sign || ftnunit->f77cplus)
01006    delta = 2;
01007       else
01008    delta = 1;
01009       n = w - (d + delta + (dp > 0 ? dp : 0));
01010       if (n > 0 && dp <= 0) {
01011    leading0 = 1;
01012    n--;
01013       }
01014 /* 9/28/89 fix bug 5046 */
01015       else if (!strlen (s) && !d && dp == 1)  /* taking care of the
01016              * case */
01017    leading0 = 1;    /* where x = 0 and d = 0 */
01018       else
01019    leading0 = 0;
01020       /* fix for zero to print as '.0' with fmt f2.1 */
01021       if (n == -1 &&    /* missed by one */
01022     dp == 1 &&    /* There is a character before the
01023          * decimal pt */
01024     *s == '0') {    /* and it is a '0' */
01025    n = dp = 0;
01026    s++;     /* skip leading 0 and start with the
01027          * dec pt */
01028       }
01029       if (n < 0) {
01030    PUT (w, '*', NULL);
01031    return (0);
01032       }
01033       if (doblank)
01034    PUT (n, ' ', NULL);
01035       if (sign)
01036    PUT (1, (char) (x==0 ? ' ' : '-'), NULL);
01037       else if (ftnunit->f77cplus)
01038    PUT (1, '+', NULL);
01039       if (leading0)
01040    PUT (1, '0', NULL);
01041       else if (dp > 0) {
01042    PUT (dp, 0, s);
01043    s += dp;
01044       }
01045       PUT (1, '.', NULL);
01046       i = (-dp) < d ? -dp : d;
01047       if (i > 0) {
01048    PUT (i, '0', NULL);
01049    d -= i;
01050       }
01051       if (d) {
01052    if ((i = (int) strlen (s))) {
01053       PUT (i > d ? d : i, 0, s);
01054       if (d > i)
01055          PUT (d - i, '0', NULL);
01056    } else
01057       PUT (d, '0', NULL);
01058       }
01059    }        /* end else */
01060    return (0);
01061 }
01062 
01063 static int 
01064 wrt_FQ (unit *ftnunit, ufloat *p, int w, int d, flag doblank)
01065 {
01066    int             i, delta, dp, sign, n, leading0;
01067    long double     x;
01068    char           *s;
01069    char     buffer[100];
01070 
01071    x = p->pld;
01072    if (w == 0) {
01073       w = 40;
01074       d = 31;
01075    }
01076    if (exceed_length(ftnunit, w)) return(110);
01077    if (ftnunit->f77scale) {
01078       if (ftnunit->f77scale > 0)
01079    for (i = 0; i < ftnunit->f77scale; i++)
01080       x *= 10;
01081       else
01082    for (i = 0; i < -ftnunit->f77scale; i++)
01083       x /= 10;
01084    }
01085    s = qfcvt_mp (x, d, &dp, &sign, buffer);
01086 /* Fix BN 11584. There is a possibility that d may be 0 in which case the string
01087  * s is empty and then the above test suceeds which should not happen. So add
01088  * the conditon that d should be non-zero.
01089  * ---ravi---1/29/92
01090  */
01091    if (!isdigit (*s) && strlen (s)) { /* just print Infinity, Nan,
01092            * etc. */
01093       PUT ((i = (int) strlen (s)), 0, s);
01094       if (doblank && w > i)
01095    PUT (w - i, ' ', NULL);/* pad to proper width */
01096    } else {
01097       if (-dp >= d)
01098    sign = 0;
01099       if (sign || ftnunit->f77cplus)
01100    delta = 2;
01101       else
01102    delta = 1;
01103       n = w - (d + delta + (dp > 0 ? dp : 0));
01104       if (n > 0 && dp <= 0) {
01105    leading0 = 1;
01106    n--;
01107       }
01108 /* 9/28/89 fix bug 5046 */
01109       else if (!strlen (s) && !d && dp == 1)  /* taking care of the
01110              * case */
01111    leading0 = 1;    /* where x = 0 and d = 0 */
01112       else
01113    leading0 = 0;
01114       /* fix for zero to print as '.0' with fmt f2.1 */
01115       if (n == -1 &&    /* missed by one */
01116     dp == 1 &&    /* There is a character before the
01117          * decimal pt */
01118     *s == '0') {    /* and it is a '0' */
01119    n = dp = 0;
01120    s++;     /* skip leading 0 and start with the
01121          * dec pt */
01122       }
01123       if (n < 0) {
01124    PUT (w, '*', NULL);
01125    return (0);
01126       }
01127       if (doblank)
01128    PUT (n, ' ', NULL);
01129       if (sign)
01130    PUT (1, (char) (x==0 ? ' ' : '-'), NULL);
01131       else if (ftnunit->f77cplus)
01132    PUT (1, '+', NULL);
01133       if (leading0)
01134    PUT (1, '0', NULL);
01135       else if (dp > 0) {
01136    PUT (dp, 0, s);
01137    s += dp;
01138       }
01139       PUT (1, '.', NULL);
01140       i = (-dp) < d ? -dp : d;
01141       if (i > 0) {
01142    PUT (i, '0', NULL);
01143    d -= i;
01144       }
01145       if (d) {
01146    if ((i = (int) strlen (s))) {
01147       PUT (i > d ? d : i, 0, s);
01148       if (d > i)
01149          PUT (d - i, '0', NULL);
01150    } else
01151       PUT (d, '0', NULL);
01152       }
01153    }        /* end else */
01154    return (0);
01155 }
01156 
01157 
01158 int wrt_G (unit *ftnunit, void *ptr, int op, int w, int d, int e, ftnlen len, ftnint type, flag doblank)
01159 {
01160     double  upper, lower, x;
01161     int   i, n, nd, ierr;
01162     short oldscale = ftnunit->f77scale;
01163     ufloat  *p = (ufloat *) ptr;
01164 
01165     switch (type) {
01166     default:
01167 /*
01168   fprintf (stderr, "w_ed, bad variable type: %d\n%s\n", type, ftnunit->f77fmtbuf);
01169 */
01170   err(CILISTERR, 117, "fmt");
01171     case TYCHAR:
01172   if (w) {
01173     return (wrt_AW (ftnunit, (char *)ptr, w, len));
01174   } else {
01175     return (wrt_A (ftnunit, (char *)ptr, len));
01176   }
01177     case TYLOGICAL1:
01178     case TYLOGICAL2:
01179     case TYLOGICAL4:
01180     case TYLOGICAL8:
01181   return (wrt_L (ftnunit, (uinteger *) ptr, w, len));
01182     case TYBYTE:
01183     case TYSHORT:
01184     case TYINT:
01185     case TYLONGLONG:
01186   return (wrt_I (ftnunit, (uinteger *) ptr, w, len));
01187     case TYREAL:
01188     case TYDREAL:
01189     case TYCOMPLEX:
01190     case TYDCOMPLEX:
01191     case TYQUAD:
01192     case TYQUADCOMPLEX:
01193   x = (len < sizeof (double)) ? p->pf : (len == sizeof (double)) ? p->pd : (double) p->pld;
01194   if (w == 0) {
01195       if (len < 8) {
01196     w = 15;
01197     d = 7;
01198       } else if (len == 8) {
01199     w = 25;
01200     d = 16;
01201       } else {
01202     w = 40;
01203     d = 31;
01204       }
01205       e = 2;
01206   }
01207 
01208   if ( d > dmax ) { /* handle cases when d > dmax */
01209       upper = exp10(dmax);
01210       lower = roundup(-dmax);
01211       nd = dmax;
01212       while ( d - nd > dmax-1 ) {
01213     upper *= exp10(dmax);
01214     lower *= exp10(-dmax);
01215     nd += dmax;
01216       }
01217       upper *= exp10(d-nd);
01218       lower *= exp10(-d+nd-1);
01219       upper = upper - 0.5;
01220       lower = .1 - lower;
01221   } else {
01222       upper = exp10(d) - roundup(0);
01223       lower = exp10(-1) - roundup(-d-1);
01224   }
01225  
01226   if (x < 0) x = -x;
01227 
01228   if ( (x == 0 && ftnunit->f90sw) || ( lower <= x && x < upper ) ) { /* range for effective use of F editing */
01229 
01230       ftnunit->f77scale = 0;
01231       if (e == 0) {
01232         n = 4;
01233       } else {
01234         n = e + 2;
01235       }
01236 
01237       for ( i = 0; i <= d; ++i ) {
01238 
01239     if ( i > dmax ) { /* handle cases when i > dmax */
01240         upper = exp10(dmax);
01241         nd = dmax;
01242         while ( i - nd > dmax ) {
01243       upper *= exp10(dmax);
01244       nd += dmax;
01245         }
01246         upper *= exp10(i-nd);
01247     } else {
01248         upper = exp10(i);
01249     }
01250     if ( d - i > dmax ) { /* handle cases when d - i > dmax */
01251         lower = roundup(-dmax);
01252         nd = dmax;
01253         while ( d - i - nd > dmax ) {
01254       lower *= exp10(-dmax);
01255       nd += dmax;
01256         }
01257         lower *= exp10(i-d+nd);
01258     } else {
01259         lower = roundup(i-d);
01260     }
01261     upper = upper - lower;
01262 
01263     if ( x < upper || i == d  ) {
01264 
01265         if (len > 8) {
01266       ierr = wrt_FQ (ftnunit, p, w - n, ( x==0 ? d-1 : d-i ), doblank);
01267         } else {
01268       ierr = wrt_F (ftnunit, p, w - n, ( x==0 ? d-1 : d-i ), len, doblank);
01269         }
01270         if (doblank) PUT (n, ' ', NULL);
01271         ftnunit->f77scale = oldscale;
01272         return (ierr);
01273 
01274     } /* endif */
01275 
01276       } /* endloop */
01277 
01278   } else { /* exponential notation */
01279 
01280       if ( op == (int)GE && e == 0 ) {
01281     err(CILISTERR, 100, "fmt");
01282       }
01283 
01284       if (len > 8) {
01285         return (wrt_EQ (ftnunit, p, w, d, e, len, 'E', doblank));
01286       } else {
01287         return (wrt_E (ftnunit, p, w, d, e, len, 'E', doblank));
01288       }
01289 
01290   }
01291 
01292     } /* switch */
01293 
01294     return (0);
01295 }
01296 
01297 
01298 int w_ed (unit *ftnunit, struct f77syl *p, char *ptr, ftnlen len, ftnint type)
01299 {
01300    if (mv_cur (ftnunit))
01301       return (mv_cur (ftnunit));
01302 #ifdef I90
01303   if (ftnunit->f90sw != 0 ) {
01304       if (ftnunit->url > 0 ) {
01305     if ( p->op == A || p->op == AW ) {
01306         if (ftnunit->f77recpos + len > ftnunit->url )
01307       err(ftnunit->f77errlist.cierr,110,"fmt");
01308     } else {
01309         if (ftnunit->f77recpos + p->p1 > ftnunit->url )
01310       err(ftnunit->f77errlist.cierr,110,"fmt");
01311     }
01312       }
01313       if ( test_type(p->op,type) != 0 )
01314     err(ftnunit->f77errlist.cierr,117,"wrtfmt");
01315   }
01316 #endif
01317 
01318    if (fmt_check && _WCHK[p->op][type]) {
01319       err(CILISTERR, F_TYPECONFLICT, "formatted write");
01320    }
01321    switch (p->op) {
01322    default:
01323 /*
01324       fprintf (stderr, "w_ed, unexpected code: %d\n%s\n",
01325          p->op, ftnunit->f77fmtbuf);
01326 */
01327       err(CILISTERR, 167, "fmt");
01328    case I:
01329       return (wrt_I (ftnunit, (uinteger *) ptr, p->p1, len));
01330    case IM:
01331       return (wrt_IM (ftnunit, (uinteger *) ptr, p->p1, p->p2, len));
01332    case O:
01333       return (wrt_OZ (ftnunit, (unsigned char *) ptr, p->p1, len, 8));
01334    case OM:
01335       return (wrt_OZM (ftnunit, (unsigned char *) ptr, p->p1, p->p2, len, 8));
01336    case Z:
01337       return (wrt_OZ (ftnunit, (unsigned char *) ptr, p->p1, len, 16));
01338    case ZM:
01339       return (wrt_OZM (ftnunit, (unsigned char *) ptr, p->p1, p->p2, len, 16));
01340    case L:
01341       return (wrt_L (ftnunit, (uinteger *) ptr, p->p1, len));
01342    case Q:
01343       return (0);
01344    case A:
01345       return (wrt_A (ftnunit, ptr, len));
01346    case AW:
01347       return (wrt_AW (ftnunit, ptr, p->p1, len));
01348    case D:
01349       if (len > 8)
01350          return (wrt_EQ (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'E', 1));
01351       else
01352          return (wrt_E (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'D', 1));
01353    case E:
01354    case EE:
01355       if (len > 8)
01356          return (wrt_EQ (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'E', 1));
01357       else
01358          return (wrt_E (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'E', 1));
01359    case G:
01360    case GE:
01361       return (wrt_G (ftnunit, (void *) ptr, p->op, p->p1, p->p2, p->p3, len, type, 1));
01362    case F:
01363       if (len > 8)
01364    return(wrt_FQ (ftnunit, (ufloat *) ptr, p->p1, p->p2, 1));
01365       else
01366          return (wrt_F (ftnunit, (ufloat *) ptr, p->p1, p->p2, len, 1));
01367 #ifdef I90
01368    case B:
01369       return (wrt_BM (ftnunit, (unsigned char *) ptr, p->p1, 1, len));
01370    case BM:
01371       return (wrt_BM (ftnunit, (unsigned char *) ptr, p->p1, p->p2, len));
01372    case EN:
01373    case ENE:
01374       if (exceed_length(ftnunit, p->p1)) return(110);
01375       if ( p->p1 == 0 || ( p->op == ENE && p->p3 == 0 ) ) {
01376    err(CILISTERR, 100, "fmt");
01377       }
01378       if (len > 8)
01379          return (wrt_ENQ (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'E', 1));
01380       else
01381          return (wrt_EN (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'E', 1));
01382    case ES:
01383    case ESE:
01384       if (exceed_length(ftnunit, p->p1)) return(110);
01385       if ( p->p1 == 0 || ( p->op == ESE && p->p3 == 0 ) ) {
01386    err(CILISTERR, 100, "fmt");
01387       }
01388       if (len > 8)
01389          return (wrt_ESQ (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'E', 1));
01390       else
01391          return (wrt_ES (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'E', 1));
01392 #endif
01393    }
01394 }
01395 
01396 #ifdef I90
01397 static int
01398 wr_slash( unit *ftnunit, long repeat_count )
01399 {
01400    int rslt;
01401    while ( repeat_count-- ) {
01402       rslt = (*ftnunit->f77donewrec)(ftnunit);
01403       if (rslt) return (rslt);
01404    }
01405    return (0);
01406 }
01407 #endif
01408 
01409 int w_ned (unit *ftnunit, struct f77syl *p)
01410 {
01411    switch (p->op) {
01412    default:
01413 /*
01414       fprintf (stderr, "w_ned, unexpected code: %d\n%s\n",
01415          p->op, ftnunit->f77fmtbuf);
01416 */
01417       err(CILISTERR, 167, "fmt");
01418    case SLASH:
01419 #ifdef I90
01420       return (wr_slash (ftnunit, p->p1));
01421 #else
01422       return ((*ftnunit->f77donewrec) (ftnunit));
01423 #endif
01424    case T:
01425       ftnunit->f77cursor = p->p1 - ftnunit->f77recpos - 1;
01426       return (0);
01427    case TL:
01428       ftnunit->f77cursor -= p->p1;
01429       if (ftnunit->f77cursor < (-ftnunit->f77recpos))
01430    ftnunit->f77cursor = -ftnunit->f77recpos;
01431       return (0);
01432    case TR:
01433    case X:
01434       ftnunit->f77cursor += p->p1;
01435       return (0);
01436    case APOS:
01437       return (wrt_AP (ftnunit, (char *)p->p1));
01438    case H:
01439       return (wrt_H (ftnunit, p->p1, (char *)p->p2));
01440    }
01441 }
01442 
01443 
01444 static int exceed_length(unit *ftnunit, int w)
01445 {
01446     if (ftnunit->f77putn==x_putc || ftnunit->f77putn==t_putc)
01447   return(0);
01448     else if (ftnunit->f77putn==y_putc) {
01449   /* direct formatted I/O */
01450   if (ftnunit->f77recpos+w > ftnunit->url && ftnunit->url > 1)
01451       return(1);
01452     } else if ((icptr + w) > icend)
01453   /* internal formatted I/O */
01454   return(1);
01455     return(0);
01456 }