From 9cb2aa328679fb9b22d5f3c1987ca4e890855176 Mon Sep 17 00:00:00 2001 From: ceriel Date: Mon, 7 Oct 1991 16:59:33 +0000 Subject: [PATCH] Added --- lang/fortran/lib/libF77/.distr | 118 +++++++ lang/fortran/lib/libF77/LIST | 113 ++++++ lang/fortran/lib/libF77/Notice | 23 ++ lang/fortran/lib/libF77/README | 20 ++ lang/fortran/lib/libF77/Version.c | 18 + lang/fortran/lib/libF77/abort_.c | 9 + lang/fortran/lib/libF77/c_abs.c | 9 + lang/fortran/lib/libF77/c_cos.c | 10 + lang/fortran/lib/libF77/c_div.c | 32 ++ lang/fortran/lib/libF77/c_exp.c | 12 + lang/fortran/lib/libF77/c_log.c | 10 + lang/fortran/lib/libF77/c_sin.c | 10 + lang/fortran/lib/libF77/c_sqrt.c | 25 ++ lang/fortran/lib/libF77/cabs.c | 21 ++ lang/fortran/lib/libF77/d_abs.c | 9 + lang/fortran/lib/libF77/d_acos.c | 8 + lang/fortran/lib/libF77/d_asin.c | 8 + lang/fortran/lib/libF77/d_atan.c | 8 + lang/fortran/lib/libF77/d_atn2.c | 8 + lang/fortran/lib/libF77/d_cnjg.c | 8 + lang/fortran/lib/libF77/d_cos.c | 8 + lang/fortran/lib/libF77/d_cosh.c | 8 + lang/fortran/lib/libF77/d_dim.c | 7 + lang/fortran/lib/libF77/d_exp.c | 8 + lang/fortran/lib/libF77/d_imag.c | 7 + lang/fortran/lib/libF77/d_int.c | 9 + lang/fortran/lib/libF77/d_lg10.c | 11 + lang/fortran/lib/libF77/d_log.c | 8 + lang/fortran/lib/libF77/d_mod.c | 26 ++ lang/fortran/lib/libF77/d_nint.c | 10 + lang/fortran/lib/libF77/d_prod.c | 7 + lang/fortran/lib/libF77/d_sign.c | 9 + lang/fortran/lib/libF77/d_sin.c | 8 + lang/fortran/lib/libF77/d_sinh.c | 8 + lang/fortran/lib/libF77/d_sqrt.c | 8 + lang/fortran/lib/libF77/d_tan.c | 8 + lang/fortran/lib/libF77/d_tanh.c | 8 + lang/fortran/lib/libF77/derf_.c | 9 + lang/fortran/lib/libF77/derfc_.c | 9 + lang/fortran/lib/libF77/ef1asc_.c | 15 + lang/fortran/lib/libF77/ef1cmc_.c | 12 + lang/fortran/lib/libF77/erf_.c | 9 + lang/fortran/lib/libF77/erfc_.c | 9 + lang/fortran/lib/libF77/getarg_.c | 27 ++ lang/fortran/lib/libF77/getenv_.c | 49 +++ lang/fortran/lib/libF77/h_abs.c | 11 + lang/fortran/lib/libF77/h_dim.c | 9 + lang/fortran/lib/libF77/h_dnnt.c | 12 + lang/fortran/lib/libF77/h_indx.c | 26 ++ lang/fortran/lib/libF77/h_len.c | 10 + lang/fortran/lib/libF77/h_mod.c | 9 + lang/fortran/lib/libF77/h_nint.c | 12 + lang/fortran/lib/libF77/h_sign.c | 11 + lang/fortran/lib/libF77/hl_ge.c | 10 + lang/fortran/lib/libF77/hl_gt.c | 10 + lang/fortran/lib/libF77/hl_le.c | 10 + lang/fortran/lib/libF77/hl_lt.c | 10 + lang/fortran/lib/libF77/i_abs.c | 9 + lang/fortran/lib/libF77/i_dim.c | 7 + lang/fortran/lib/libF77/i_dnnt.c | 10 + lang/fortran/lib/libF77/i_indx.c | 24 ++ lang/fortran/lib/libF77/i_len.c | 8 + lang/fortran/lib/libF77/i_mod.c | 7 + lang/fortran/lib/libF77/i_nint.c | 10 + lang/fortran/lib/libF77/i_sign.c | 9 + lang/fortran/lib/libF77/iargc_.c | 7 + lang/fortran/lib/libF77/l_ge.c | 10 + lang/fortran/lib/libF77/l_gt.c | 10 + lang/fortran/lib/libF77/l_le.c | 10 + lang/fortran/lib/libF77/l_lt.c | 8 + lang/fortran/lib/libF77/libF77.xsum | 116 ++++++ lang/fortran/lib/libF77/main.c | 95 +++++ lang/fortran/lib/libF77/makefile | 74 ++++ lang/fortran/lib/libF77/pow_ci.c | 16 + lang/fortran/lib/libF77/pow_dd.c | 9 + lang/fortran/lib/libF77/pow_di.c | 36 ++ lang/fortran/lib/libF77/pow_hh.c | 25 ++ lang/fortran/lib/libF77/pow_ii.c | 25 ++ lang/fortran/lib/libF77/pow_ri.c | 36 ++ lang/fortran/lib/libF77/pow_zi.c | 46 +++ lang/fortran/lib/libF77/pow_zz.c | 17 + lang/fortran/lib/libF77/r_abs.c | 9 + lang/fortran/lib/libF77/r_acos.c | 8 + lang/fortran/lib/libF77/r_asin.c | 8 + lang/fortran/lib/libF77/r_atan.c | 8 + lang/fortran/lib/libF77/r_atn2.c | 8 + lang/fortran/lib/libF77/r_cnjg.c | 8 + lang/fortran/lib/libF77/r_cos.c | 8 + lang/fortran/lib/libF77/r_cosh.c | 8 + lang/fortran/lib/libF77/r_dim.c | 7 + lang/fortran/lib/libF77/r_exp.c | 8 + lang/fortran/lib/libF77/r_imag.c | 7 + lang/fortran/lib/libF77/r_int.c | 9 + lang/fortran/lib/libF77/r_lg10.c | 11 + lang/fortran/lib/libF77/r_log.c | 8 + lang/fortran/lib/libF77/r_mod.c | 26 ++ lang/fortran/lib/libF77/r_nint.c | 10 + lang/fortran/lib/libF77/r_sign.c | 9 + lang/fortran/lib/libF77/r_sin.c | 8 + lang/fortran/lib/libF77/r_sinh.c | 8 + lang/fortran/lib/libF77/r_sqrt.c | 8 + lang/fortran/lib/libF77/r_tan.c | 8 + lang/fortran/lib/libF77/r_tanh.c | 8 + lang/fortran/lib/libF77/s_cat.c | 23 ++ lang/fortran/lib/libF77/s_cmp.c | 38 ++ lang/fortran/lib/libF77/s_copy.c | 23 ++ lang/fortran/lib/libF77/s_paus.c | 41 +++ lang/fortran/lib/libF77/s_rnge.c | 21 ++ lang/fortran/lib/libF77/s_stop.c | 19 + lang/fortran/lib/libF77/sig_die.c | 28 ++ lang/fortran/lib/libF77/signal_.c | 15 + lang/fortran/lib/libF77/system_.c | 19 + lang/fortran/lib/libF77/z_abs.c | 9 + lang/fortran/lib/libF77/z_cos.c | 10 + lang/fortran/lib/libF77/z_div.c | 33 ++ lang/fortran/lib/libF77/z_exp.c | 12 + lang/fortran/lib/libF77/z_log.c | 10 + lang/fortran/lib/libF77/z_sin.c | 10 + lang/fortran/lib/libF77/z_sqrt.c | 22 ++ lang/fortran/lib/libI77/.distr | 42 +++ lang/fortran/lib/libI77/LIST | 37 ++ lang/fortran/lib/libI77/Notice | 23 ++ lang/fortran/lib/libI77/README | 92 +++++ lang/fortran/lib/libI77/Version.c | 94 +++++ lang/fortran/lib/libI77/backspace.c | 63 ++++ lang/fortran/lib/libI77/close.c | 59 ++++ lang/fortran/lib/libI77/dfe.c | 136 +++++++ lang/fortran/lib/libI77/dolio.c | 7 + lang/fortran/lib/libI77/due.c | 51 +++ lang/fortran/lib/libI77/endfile.c | 83 +++++ lang/fortran/lib/libI77/err.c | 223 ++++++++++++ lang/fortran/lib/libI77/fio.h | 65 ++++ lang/fortran/lib/libI77/fmt.c | 434 +++++++++++++++++++++++ lang/fortran/lib/libI77/fmt.h | 57 +++ lang/fortran/lib/libI77/fmtlib.c | 24 ++ lang/fortran/lib/libI77/fp.h | 26 ++ lang/fortran/lib/libI77/iio.c | 116 ++++++ lang/fortran/lib/libI77/ilnw.c | 62 ++++ lang/fortran/lib/libI77/inquire.c | 93 +++++ lang/fortran/lib/libI77/libI77.xsum | 39 +++ lang/fortran/lib/libI77/lio.h | 41 +++ lang/fortran/lib/libI77/local.h | 0 lang/fortran/lib/libI77/lread.c | 526 ++++++++++++++++++++++++++++ lang/fortran/lib/libI77/lwrite.c | 148 ++++++++ lang/fortran/lib/libI77/makefile | 92 +++++ lang/fortran/lib/libI77/open.c | 190 ++++++++++ lang/fortran/lib/libI77/rdfmt.c | 324 +++++++++++++++++ lang/fortran/lib/libI77/rewind.c | 20 ++ lang/fortran/lib/libI77/rsfe.c | 70 ++++ lang/fortran/lib/libI77/rsli.c | 80 +++++ lang/fortran/lib/libI77/rsne.c | 444 +++++++++++++++++++++++ lang/fortran/lib/libI77/sfe.c | 28 ++ lang/fortran/lib/libI77/sue.c | 67 ++++ lang/fortran/lib/libI77/typesize.c | 6 + lang/fortran/lib/libI77/uio.c | 43 +++ lang/fortran/lib/libI77/util.c | 53 +++ lang/fortran/lib/libI77/wref.c | 224 ++++++++++++ lang/fortran/lib/libI77/wrtfmt.c | 250 +++++++++++++ lang/fortran/lib/libI77/wsfe.c | 85 +++++ lang/fortran/lib/libI77/wsle.c | 33 ++ lang/fortran/lib/libI77/wsne.c | 27 ++ lang/fortran/lib/libI77/xwsne.c | 53 +++ 162 files changed, 6703 insertions(+) create mode 100644 lang/fortran/lib/libF77/.distr create mode 100644 lang/fortran/lib/libF77/LIST create mode 100644 lang/fortran/lib/libF77/Notice create mode 100644 lang/fortran/lib/libF77/README create mode 100644 lang/fortran/lib/libF77/Version.c create mode 100644 lang/fortran/lib/libF77/abort_.c create mode 100644 lang/fortran/lib/libF77/c_abs.c create mode 100644 lang/fortran/lib/libF77/c_cos.c create mode 100644 lang/fortran/lib/libF77/c_div.c create mode 100644 lang/fortran/lib/libF77/c_exp.c create mode 100644 lang/fortran/lib/libF77/c_log.c create mode 100644 lang/fortran/lib/libF77/c_sin.c create mode 100644 lang/fortran/lib/libF77/c_sqrt.c create mode 100644 lang/fortran/lib/libF77/cabs.c create mode 100644 lang/fortran/lib/libF77/d_abs.c create mode 100644 lang/fortran/lib/libF77/d_acos.c create mode 100644 lang/fortran/lib/libF77/d_asin.c create mode 100644 lang/fortran/lib/libF77/d_atan.c create mode 100644 lang/fortran/lib/libF77/d_atn2.c create mode 100644 lang/fortran/lib/libF77/d_cnjg.c create mode 100644 lang/fortran/lib/libF77/d_cos.c create mode 100644 lang/fortran/lib/libF77/d_cosh.c create mode 100644 lang/fortran/lib/libF77/d_dim.c create mode 100644 lang/fortran/lib/libF77/d_exp.c create mode 100644 lang/fortran/lib/libF77/d_imag.c create mode 100644 lang/fortran/lib/libF77/d_int.c create mode 100644 lang/fortran/lib/libF77/d_lg10.c create mode 100644 lang/fortran/lib/libF77/d_log.c create mode 100644 lang/fortran/lib/libF77/d_mod.c create mode 100644 lang/fortran/lib/libF77/d_nint.c create mode 100644 lang/fortran/lib/libF77/d_prod.c create mode 100644 lang/fortran/lib/libF77/d_sign.c create mode 100644 lang/fortran/lib/libF77/d_sin.c create mode 100644 lang/fortran/lib/libF77/d_sinh.c create mode 100644 lang/fortran/lib/libF77/d_sqrt.c create mode 100644 lang/fortran/lib/libF77/d_tan.c create mode 100644 lang/fortran/lib/libF77/d_tanh.c create mode 100644 lang/fortran/lib/libF77/derf_.c create mode 100644 lang/fortran/lib/libF77/derfc_.c create mode 100644 lang/fortran/lib/libF77/ef1asc_.c create mode 100644 lang/fortran/lib/libF77/ef1cmc_.c create mode 100644 lang/fortran/lib/libF77/erf_.c create mode 100644 lang/fortran/lib/libF77/erfc_.c create mode 100644 lang/fortran/lib/libF77/getarg_.c create mode 100644 lang/fortran/lib/libF77/getenv_.c create mode 100644 lang/fortran/lib/libF77/h_abs.c create mode 100644 lang/fortran/lib/libF77/h_dim.c create mode 100644 lang/fortran/lib/libF77/h_dnnt.c create mode 100644 lang/fortran/lib/libF77/h_indx.c create mode 100644 lang/fortran/lib/libF77/h_len.c create mode 100644 lang/fortran/lib/libF77/h_mod.c create mode 100644 lang/fortran/lib/libF77/h_nint.c create mode 100644 lang/fortran/lib/libF77/h_sign.c create mode 100644 lang/fortran/lib/libF77/hl_ge.c create mode 100644 lang/fortran/lib/libF77/hl_gt.c create mode 100644 lang/fortran/lib/libF77/hl_le.c create mode 100644 lang/fortran/lib/libF77/hl_lt.c create mode 100644 lang/fortran/lib/libF77/i_abs.c create mode 100644 lang/fortran/lib/libF77/i_dim.c create mode 100644 lang/fortran/lib/libF77/i_dnnt.c create mode 100644 lang/fortran/lib/libF77/i_indx.c create mode 100644 lang/fortran/lib/libF77/i_len.c create mode 100644 lang/fortran/lib/libF77/i_mod.c create mode 100644 lang/fortran/lib/libF77/i_nint.c create mode 100644 lang/fortran/lib/libF77/i_sign.c create mode 100644 lang/fortran/lib/libF77/iargc_.c create mode 100644 lang/fortran/lib/libF77/l_ge.c create mode 100644 lang/fortran/lib/libF77/l_gt.c create mode 100644 lang/fortran/lib/libF77/l_le.c create mode 100644 lang/fortran/lib/libF77/l_lt.c create mode 100644 lang/fortran/lib/libF77/libF77.xsum create mode 100644 lang/fortran/lib/libF77/main.c create mode 100644 lang/fortran/lib/libF77/makefile create mode 100644 lang/fortran/lib/libF77/pow_ci.c create mode 100644 lang/fortran/lib/libF77/pow_dd.c create mode 100644 lang/fortran/lib/libF77/pow_di.c create mode 100644 lang/fortran/lib/libF77/pow_hh.c create mode 100644 lang/fortran/lib/libF77/pow_ii.c create mode 100644 lang/fortran/lib/libF77/pow_ri.c create mode 100644 lang/fortran/lib/libF77/pow_zi.c create mode 100644 lang/fortran/lib/libF77/pow_zz.c create mode 100644 lang/fortran/lib/libF77/r_abs.c create mode 100644 lang/fortran/lib/libF77/r_acos.c create mode 100644 lang/fortran/lib/libF77/r_asin.c create mode 100644 lang/fortran/lib/libF77/r_atan.c create mode 100644 lang/fortran/lib/libF77/r_atn2.c create mode 100644 lang/fortran/lib/libF77/r_cnjg.c create mode 100644 lang/fortran/lib/libF77/r_cos.c create mode 100644 lang/fortran/lib/libF77/r_cosh.c create mode 100644 lang/fortran/lib/libF77/r_dim.c create mode 100644 lang/fortran/lib/libF77/r_exp.c create mode 100644 lang/fortran/lib/libF77/r_imag.c create mode 100644 lang/fortran/lib/libF77/r_int.c create mode 100644 lang/fortran/lib/libF77/r_lg10.c create mode 100644 lang/fortran/lib/libF77/r_log.c create mode 100644 lang/fortran/lib/libF77/r_mod.c create mode 100644 lang/fortran/lib/libF77/r_nint.c create mode 100644 lang/fortran/lib/libF77/r_sign.c create mode 100644 lang/fortran/lib/libF77/r_sin.c create mode 100644 lang/fortran/lib/libF77/r_sinh.c create mode 100644 lang/fortran/lib/libF77/r_sqrt.c create mode 100644 lang/fortran/lib/libF77/r_tan.c create mode 100644 lang/fortran/lib/libF77/r_tanh.c create mode 100644 lang/fortran/lib/libF77/s_cat.c create mode 100644 lang/fortran/lib/libF77/s_cmp.c create mode 100644 lang/fortran/lib/libF77/s_copy.c create mode 100644 lang/fortran/lib/libF77/s_paus.c create mode 100644 lang/fortran/lib/libF77/s_rnge.c create mode 100644 lang/fortran/lib/libF77/s_stop.c create mode 100644 lang/fortran/lib/libF77/sig_die.c create mode 100644 lang/fortran/lib/libF77/signal_.c create mode 100644 lang/fortran/lib/libF77/system_.c create mode 100644 lang/fortran/lib/libF77/z_abs.c create mode 100644 lang/fortran/lib/libF77/z_cos.c create mode 100644 lang/fortran/lib/libF77/z_div.c create mode 100644 lang/fortran/lib/libF77/z_exp.c create mode 100644 lang/fortran/lib/libF77/z_log.c create mode 100644 lang/fortran/lib/libF77/z_sin.c create mode 100644 lang/fortran/lib/libF77/z_sqrt.c create mode 100644 lang/fortran/lib/libI77/.distr create mode 100644 lang/fortran/lib/libI77/LIST create mode 100644 lang/fortran/lib/libI77/Notice create mode 100644 lang/fortran/lib/libI77/README create mode 100644 lang/fortran/lib/libI77/Version.c create mode 100644 lang/fortran/lib/libI77/backspace.c create mode 100644 lang/fortran/lib/libI77/close.c create mode 100644 lang/fortran/lib/libI77/dfe.c create mode 100644 lang/fortran/lib/libI77/dolio.c create mode 100644 lang/fortran/lib/libI77/due.c create mode 100644 lang/fortran/lib/libI77/endfile.c create mode 100644 lang/fortran/lib/libI77/err.c create mode 100644 lang/fortran/lib/libI77/fio.h create mode 100644 lang/fortran/lib/libI77/fmt.c create mode 100644 lang/fortran/lib/libI77/fmt.h create mode 100644 lang/fortran/lib/libI77/fmtlib.c create mode 100644 lang/fortran/lib/libI77/fp.h create mode 100644 lang/fortran/lib/libI77/iio.c create mode 100644 lang/fortran/lib/libI77/ilnw.c create mode 100644 lang/fortran/lib/libI77/inquire.c create mode 100644 lang/fortran/lib/libI77/libI77.xsum create mode 100644 lang/fortran/lib/libI77/lio.h create mode 100644 lang/fortran/lib/libI77/local.h create mode 100644 lang/fortran/lib/libI77/lread.c create mode 100644 lang/fortran/lib/libI77/lwrite.c create mode 100644 lang/fortran/lib/libI77/makefile create mode 100644 lang/fortran/lib/libI77/open.c create mode 100644 lang/fortran/lib/libI77/rdfmt.c create mode 100644 lang/fortran/lib/libI77/rewind.c create mode 100644 lang/fortran/lib/libI77/rsfe.c create mode 100644 lang/fortran/lib/libI77/rsli.c create mode 100644 lang/fortran/lib/libI77/rsne.c create mode 100644 lang/fortran/lib/libI77/sfe.c create mode 100644 lang/fortran/lib/libI77/sue.c create mode 100644 lang/fortran/lib/libI77/typesize.c create mode 100644 lang/fortran/lib/libI77/uio.c create mode 100644 lang/fortran/lib/libI77/util.c create mode 100644 lang/fortran/lib/libI77/wref.c create mode 100644 lang/fortran/lib/libI77/wrtfmt.c create mode 100644 lang/fortran/lib/libI77/wsfe.c create mode 100644 lang/fortran/lib/libI77/wsle.c create mode 100644 lang/fortran/lib/libI77/wsne.c create mode 100644 lang/fortran/lib/libI77/xwsne.c diff --git a/lang/fortran/lib/libF77/.distr b/lang/fortran/lib/libF77/.distr new file mode 100644 index 000000000..555cf9635 --- /dev/null +++ b/lang/fortran/lib/libF77/.distr @@ -0,0 +1,118 @@ +LIST +Notice +README +Version.c +abort_.c +c_abs.c +c_cos.c +c_div.c +c_exp.c +c_log.c +c_sin.c +c_sqrt.c +cabs.c +d_abs.c +d_acos.c +d_asin.c +d_atan.c +d_atn2.c +d_cnjg.c +d_cos.c +d_cosh.c +d_dim.c +d_exp.c +d_imag.c +d_int.c +d_lg10.c +d_log.c +d_mod.c +d_nint.c +d_prod.c +d_sign.c +d_sin.c +d_sinh.c +d_sqrt.c +d_tan.c +d_tanh.c +derf_.c +derfc_.c +ef1asc_.c +ef1cmc_.c +erf_.c +erfc_.c +getarg_.c +getenv_.c +h_abs.c +h_dim.c +h_dnnt.c +h_indx.c +h_len.c +h_mod.c +h_nint.c +h_sign.c +hl_ge.c +hl_gt.c +hl_le.c +hl_lt.c +i_abs.c +i_dim.c +i_dnnt.c +i_indx.c +i_len.c +i_mod.c +i_nint.c +i_sign.c +iargc_.c +l_ge.c +l_gt.c +l_le.c +l_lt.c +libF77.xsum +main.c +makefile +pow_ci.c +pow_dd.c +pow_di.c +pow_hh.c +pow_ii.c +pow_ri.c +pow_zi.c +pow_zz.c +r_abs.c +r_acos.c +r_asin.c +r_atan.c +r_atn2.c +r_cnjg.c +r_cos.c +r_cosh.c +r_dim.c +r_exp.c +r_imag.c +r_int.c +r_lg10.c +r_log.c +r_mod.c +r_nint.c +r_sign.c +r_sin.c +r_sinh.c +r_sqrt.c +r_tan.c +r_tanh.c +s_cat.c +s_cmp.c +s_copy.c +s_paus.c +s_rnge.c +s_stop.c +sig_die.c +signal_.c +system_.c +z_abs.c +z_cos.c +z_div.c +z_exp.c +z_log.c +z_sin.c +z_sqrt.c diff --git a/lang/fortran/lib/libF77/LIST b/lang/fortran/lib/libF77/LIST new file mode 100644 index 000000000..e8797be27 --- /dev/null +++ b/lang/fortran/lib/libF77/LIST @@ -0,0 +1,113 @@ +Version.c +abort_.c +c_abs.c +c_cos.c +c_div.c +c_exp.c +c_log.c +c_sin.c +c_sqrt.c +cabs.c +d_abs.c +d_acos.c +d_asin.c +d_atan.c +d_atn2.c +d_cnjg.c +d_cos.c +d_cosh.c +d_dim.c +d_exp.c +d_imag.c +d_int.c +d_lg10.c +d_log.c +d_mod.c +d_nint.c +d_prod.c +d_sign.c +d_sin.c +d_sinh.c +d_sqrt.c +d_tan.c +d_tanh.c +derf_.c +derfc_.c +ef1asc_.c +ef1cmc_.c +erf_.c +erfc_.c +getarg_.c +getenv_.c +h_abs.c +h_dim.c +h_dnnt.c +h_indx.c +h_len.c +h_mod.c +h_nint.c +h_sign.c +hl_ge.c +hl_gt.c +hl_le.c +hl_lt.c +i_abs.c +i_dim.c +i_dnnt.c +i_indx.c +i_len.c +i_mod.c +i_nint.c +i_sign.c +iargc_.c +l_ge.c +l_gt.c +l_le.c +l_lt.c +main.c +pow_ci.c +pow_dd.c +pow_di.c +pow_hh.c +pow_ii.c +pow_ri.c +pow_zi.c +pow_zz.c +r_abs.c +r_acos.c +r_asin.c +r_atan.c +r_atn2.c +r_cnjg.c +r_cos.c +r_cosh.c +r_dim.c +r_exp.c +r_imag.c +r_int.c +r_lg10.c +r_log.c +r_mod.c +r_nint.c +r_sign.c +r_sin.c +r_sinh.c +r_sqrt.c +r_tan.c +r_tanh.c +s_cat.c +s_cmp.c +s_copy.c +s_paus.c +s_rnge.c +s_stop.c +sig_die.c +signal_.c +system_.c +z_abs.c +z_cos.c +z_div.c +z_exp.c +z_log.c +z_sin.c +z_sqrt.c diff --git a/lang/fortran/lib/libF77/Notice b/lang/fortran/lib/libF77/Notice new file mode 100644 index 000000000..ec5f903dc --- /dev/null +++ b/lang/fortran/lib/libF77/Notice @@ -0,0 +1,23 @@ +/**************************************************************** +Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + diff --git a/lang/fortran/lib/libF77/README b/lang/fortran/lib/libF77/README new file mode 100644 index 000000000..a07a70fdb --- /dev/null +++ b/lang/fortran/lib/libF77/README @@ -0,0 +1,20 @@ +If your system lacks onexit() and you are not using an ANSI C +compiler, then you should compile main.c with NO_ONEXIT defined. +See the comments about onexit in the makefile. + +If your system has a double drem() function such that drem(a,b) +is the IEEE remainder function (with double a, b), then you may +wish to compile r_mod.c and d_mod.c with IEEE_drem defined. + +To check for transmission errors, issue the command + make check +This assumes you have the xsum program whose source, xsum.c, +is distributed as part of "all from f2c/src". If you do not +have xsum, you can obtain xsum.c by sending the following E-mail +message to netlib@research.att.com + send xsum.c from f2c/src + +The makefile assumes you have installed f2c.h in a standard +place (and does not cause recompilation when f2c.h is changed); +f2c.h comes with "all from f2c" (the source for f2c) and is +available separately ("f2c.h from f2c"). diff --git a/lang/fortran/lib/libF77/Version.c b/lang/fortran/lib/libF77/Version.c new file mode 100644 index 000000000..4131f961e --- /dev/null +++ b/lang/fortran/lib/libF77/Version.c @@ -0,0 +1,18 @@ +static char junk[] = "\n@(#)LIBF77 VERSION 2.01 31 May 1991\n"; + +/* +2.00 11 June 1980. File version.c added to library. +2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed + [ d]erf[c ] added + 8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c + 29 Nov. 1989: s_cmp returns long (for f2c) + 30 Nov. 1989: arg types from f2c.h + 12 Dec. 1989: s_rnge allows long names + 19 Dec. 1989: getenv_ allows unsorted environment + 28 Mar. 1990: add exit(0) to end of main() + 2 Oct. 1990: test signal(...) == SIG_IGN rather than & 01 in main + 17 Oct. 1990: abort() calls changed to sig_die(...,1) + 22 Oct. 1990: separate sig_die from main + 25 Apr. 1991: minor, theoretically invisible tweaks to s_cat, sig_die + 31 May 1991: make system_ return status +*/ diff --git a/lang/fortran/lib/libF77/abort_.c b/lang/fortran/lib/libF77/abort_.c new file mode 100644 index 000000000..bcbe98778 --- /dev/null +++ b/lang/fortran/lib/libF77/abort_.c @@ -0,0 +1,9 @@ +#include "stdio.h" +#include "f2c.h" + +extern VOID sig_die(); + +VOID abort_() +{ +sig_die("Fortran abort routine called", 1); +} diff --git a/lang/fortran/lib/libF77/c_abs.c b/lang/fortran/lib/libF77/c_abs.c new file mode 100644 index 000000000..f48003298 --- /dev/null +++ b/lang/fortran/lib/libF77/c_abs.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +double c_abs(z) +complex *z; +{ +double cabs(); + +return( cabs( z->r, z->i ) ); +} diff --git a/lang/fortran/lib/libF77/c_cos.c b/lang/fortran/lib/libF77/c_cos.c new file mode 100644 index 000000000..ab1617976 --- /dev/null +++ b/lang/fortran/lib/libF77/c_cos.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +VOID c_cos(r, z) +complex *r, *z; +{ +double sin(), cos(), sinh(), cosh(); + +r->r = cos(z->r) * cosh(z->i); +r->i = - sin(z->r) * sinh(z->i); +} diff --git a/lang/fortran/lib/libF77/c_div.c b/lang/fortran/lib/libF77/c_div.c new file mode 100644 index 000000000..b44e7c866 --- /dev/null +++ b/lang/fortran/lib/libF77/c_div.c @@ -0,0 +1,32 @@ +#include "f2c.h" + +extern VOID sig_die(); + +VOID c_div(c, a, b) +complex *a, *b, *c; +{ +double ratio, den; +double abr, abi; + +if( (abr = b->r) < 0.) + abr = - abr; +if( (abi = b->i) < 0.) + abi = - abi; +if( abr <= abi ) + { + if(abi == 0) + sig_die("complex division by zero", 1); + ratio = (double)b->r / b->i ; + den = b->i * (1 + ratio*ratio); + c->r = (a->r*ratio + a->i) / den; + c->i = (a->i*ratio - a->r) / den; + } + +else + { + ratio = (double)b->i / b->r ; + den = b->r * (1 + ratio*ratio); + c->r = (a->r + a->i*ratio) / den; + c->i = (a->i - a->r*ratio) / den; + } +} diff --git a/lang/fortran/lib/libF77/c_exp.c b/lang/fortran/lib/libF77/c_exp.c new file mode 100644 index 000000000..781778d2d --- /dev/null +++ b/lang/fortran/lib/libF77/c_exp.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +VOID c_exp(r, z) +complex *r, *z; +{ +double expx; +double exp(), cos(), sin(); + +expx = exp(z->r); +r->r = expx * cos(z->i); +r->i = expx * sin(z->i); +} diff --git a/lang/fortran/lib/libF77/c_log.c b/lang/fortran/lib/libF77/c_log.c new file mode 100644 index 000000000..60a16a01b --- /dev/null +++ b/lang/fortran/lib/libF77/c_log.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +VOID c_log(r, z) +complex *r, *z; +{ +double log(), cabs(), atan2(); + +r->i = atan2(z->i, z->r); +r->r = log( cabs(z->r, z->i) ); +} diff --git a/lang/fortran/lib/libF77/c_sin.c b/lang/fortran/lib/libF77/c_sin.c new file mode 100644 index 000000000..37dc98550 --- /dev/null +++ b/lang/fortran/lib/libF77/c_sin.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +VOID c_sin(r, z) +complex *r, *z; +{ +double sin(), cos(), sinh(), cosh(); + +r->r = sin(z->r) * cosh(z->i); +r->i = cos(z->r) * sinh(z->i); +} diff --git a/lang/fortran/lib/libF77/c_sqrt.c b/lang/fortran/lib/libF77/c_sqrt.c new file mode 100644 index 000000000..129711d1a --- /dev/null +++ b/lang/fortran/lib/libF77/c_sqrt.c @@ -0,0 +1,25 @@ +#include "f2c.h" + +VOID c_sqrt(r, z) +complex *r, *z; +{ +double mag, t, sqrt(), cabs(); + +if( (mag = cabs(z->r, z->i)) == 0.) + r->r = r->i = 0.; +else if(z->r > 0) + { + r->r = t = sqrt(0.5 * (mag + z->r) ); + t = z->i / t; + r->i = 0.5 * t; + } +else + { + t = sqrt(0.5 * (mag - z->r) ); + if(z->i < 0) + t = -t; + r->i = t; + t = z->i / t; + r->r = 0.5 * t; + } +} diff --git a/lang/fortran/lib/libF77/cabs.c b/lang/fortran/lib/libF77/cabs.c new file mode 100644 index 000000000..b2b3e4f40 --- /dev/null +++ b/lang/fortran/lib/libF77/cabs.c @@ -0,0 +1,21 @@ +double cabs(real, imag) +double real, imag; +{ +double temp, sqrt(); + +if(real < 0) + real = -real; +if(imag < 0) + imag = -imag; +if(imag > real){ + temp = real; + real = imag; + imag = temp; +} +if((real+imag) == real) + return(real); + +temp = imag/real; +temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/ +return(temp); +} diff --git a/lang/fortran/lib/libF77/d_abs.c b/lang/fortran/lib/libF77/d_abs.c new file mode 100644 index 000000000..22649d92c --- /dev/null +++ b/lang/fortran/lib/libF77/d_abs.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +double d_abs(x) +doublereal *x; +{ +if(*x >= 0) + return(*x); +return(- *x); +} diff --git a/lang/fortran/lib/libF77/d_acos.c b/lang/fortran/lib/libF77/d_acos.c new file mode 100644 index 000000000..e08ebfd2b --- /dev/null +++ b/lang/fortran/lib/libF77/d_acos.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double d_acos(x) +doublereal *x; +{ +double acos(); +return( acos(*x) ); +} diff --git a/lang/fortran/lib/libF77/d_asin.c b/lang/fortran/lib/libF77/d_asin.c new file mode 100644 index 000000000..4d6f6ac42 --- /dev/null +++ b/lang/fortran/lib/libF77/d_asin.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double d_asin(x) +doublereal *x; +{ +double asin(); +return( asin(*x) ); +} diff --git a/lang/fortran/lib/libF77/d_atan.c b/lang/fortran/lib/libF77/d_atan.c new file mode 100644 index 000000000..71e9c83e3 --- /dev/null +++ b/lang/fortran/lib/libF77/d_atan.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double d_atan(x) +doublereal *x; +{ +double atan(); +return( atan(*x) ); +} diff --git a/lang/fortran/lib/libF77/d_atn2.c b/lang/fortran/lib/libF77/d_atn2.c new file mode 100644 index 000000000..e49898cd6 --- /dev/null +++ b/lang/fortran/lib/libF77/d_atn2.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double d_atn2(x,y) +doublereal *x, *y; +{ +double atan2(); +return( atan2(*x,*y) ); +} diff --git a/lang/fortran/lib/libF77/d_cnjg.c b/lang/fortran/lib/libF77/d_cnjg.c new file mode 100644 index 000000000..8df10d6b5 --- /dev/null +++ b/lang/fortran/lib/libF77/d_cnjg.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +d_cnjg(r, z) +doublecomplex *r, *z; +{ +r->r = z->r; +r->i = - z->i; +} diff --git a/lang/fortran/lib/libF77/d_cos.c b/lang/fortran/lib/libF77/d_cos.c new file mode 100644 index 000000000..80b7b49ef --- /dev/null +++ b/lang/fortran/lib/libF77/d_cos.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double d_cos(x) +doublereal *x; +{ +double cos(); +return( cos(*x) ); +} diff --git a/lang/fortran/lib/libF77/d_cosh.c b/lang/fortran/lib/libF77/d_cosh.c new file mode 100644 index 000000000..23dfea445 --- /dev/null +++ b/lang/fortran/lib/libF77/d_cosh.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double d_cosh(x) +doublereal *x; +{ +double cosh(); +return( cosh(*x) ); +} diff --git a/lang/fortran/lib/libF77/d_dim.c b/lang/fortran/lib/libF77/d_dim.c new file mode 100644 index 000000000..b14aa548e --- /dev/null +++ b/lang/fortran/lib/libF77/d_dim.c @@ -0,0 +1,7 @@ +#include "f2c.h" + +double d_dim(a,b) +doublereal *a, *b; +{ +return( *a > *b ? *a - *b : 0); +} diff --git a/lang/fortran/lib/libF77/d_exp.c b/lang/fortran/lib/libF77/d_exp.c new file mode 100644 index 000000000..449890de9 --- /dev/null +++ b/lang/fortran/lib/libF77/d_exp.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double d_exp(x) +doublereal *x; +{ +double exp(); +return( exp(*x) ); +} diff --git a/lang/fortran/lib/libF77/d_imag.c b/lang/fortran/lib/libF77/d_imag.c new file mode 100644 index 000000000..e12be3499 --- /dev/null +++ b/lang/fortran/lib/libF77/d_imag.c @@ -0,0 +1,7 @@ +#include "f2c.h" + +double d_imag(z) +doublecomplex *z; +{ +return(z->i); +} diff --git a/lang/fortran/lib/libF77/d_int.c b/lang/fortran/lib/libF77/d_int.c new file mode 100644 index 000000000..a038eb16c --- /dev/null +++ b/lang/fortran/lib/libF77/d_int.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +double d_int(x) +doublereal *x; +{ +double floor(); + +return( (*x>0) ? floor(*x) : -floor(- *x) ); +} diff --git a/lang/fortran/lib/libF77/d_lg10.c b/lang/fortran/lib/libF77/d_lg10.c new file mode 100644 index 000000000..1ec24bae5 --- /dev/null +++ b/lang/fortran/lib/libF77/d_lg10.c @@ -0,0 +1,11 @@ +#include "f2c.h" + +#define log10e 0.43429448190325182765 + +double d_lg10(x) +doublereal *x; +{ +double log(); + +return( log10e * log(*x) ); +} diff --git a/lang/fortran/lib/libF77/d_log.c b/lang/fortran/lib/libF77/d_log.c new file mode 100644 index 000000000..f6ce57335 --- /dev/null +++ b/lang/fortran/lib/libF77/d_log.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double d_log(x) +doublereal *x; +{ +double log(); +return( log(*x) ); +} diff --git a/lang/fortran/lib/libF77/d_mod.c b/lang/fortran/lib/libF77/d_mod.c new file mode 100644 index 000000000..a15f87789 --- /dev/null +++ b/lang/fortran/lib/libF77/d_mod.c @@ -0,0 +1,26 @@ +#include "f2c.h" + +double d_mod(x,y) +doublereal *x, *y; +{ +#ifdef IEEE_drem + double drem(), xa, ya, z; + if ((ya = *y) < 0.) + ya = -ya; + z = drem(xa = *x, ya); + if (xa > 0) { + if (z < 0) + z += ya; + } + else if (z > 0) + z -= ya; + return z; +#else + double floor(), quotient; + if( (quotient = *x / *y) >= 0) + quotient = floor(quotient); + else + quotient = -floor(-quotient); + return(*x - (*y) * quotient ); +#endif +} diff --git a/lang/fortran/lib/libF77/d_nint.c b/lang/fortran/lib/libF77/d_nint.c new file mode 100644 index 000000000..fd3ff4a4f --- /dev/null +++ b/lang/fortran/lib/libF77/d_nint.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +double d_nint(x) +doublereal *x; +{ +double floor(); + +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} diff --git a/lang/fortran/lib/libF77/d_prod.c b/lang/fortran/lib/libF77/d_prod.c new file mode 100644 index 000000000..23a1d3c3a --- /dev/null +++ b/lang/fortran/lib/libF77/d_prod.c @@ -0,0 +1,7 @@ +#include "f2c.h" + +double d_prod(x,y) +real *x, *y; +{ +return( (*x) * (*y) ); +} diff --git a/lang/fortran/lib/libF77/d_sign.c b/lang/fortran/lib/libF77/d_sign.c new file mode 100644 index 000000000..b2cae50ab --- /dev/null +++ b/lang/fortran/lib/libF77/d_sign.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +double d_sign(a,b) +doublereal *a, *b; +{ +double x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} diff --git a/lang/fortran/lib/libF77/d_sin.c b/lang/fortran/lib/libF77/d_sin.c new file mode 100644 index 000000000..6db4a56ac --- /dev/null +++ b/lang/fortran/lib/libF77/d_sin.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double d_sin(x) +doublereal *x; +{ +double sin(); +return( sin(*x) ); +} diff --git a/lang/fortran/lib/libF77/d_sinh.c b/lang/fortran/lib/libF77/d_sinh.c new file mode 100644 index 000000000..0156f3eaf --- /dev/null +++ b/lang/fortran/lib/libF77/d_sinh.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double d_sinh(x) +doublereal *x; +{ +double sinh(); +return( sinh(*x) ); +} diff --git a/lang/fortran/lib/libF77/d_sqrt.c b/lang/fortran/lib/libF77/d_sqrt.c new file mode 100644 index 000000000..16300a6b5 --- /dev/null +++ b/lang/fortran/lib/libF77/d_sqrt.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double d_sqrt(x) +doublereal *x; +{ +double sqrt(); +return( sqrt(*x) ); +} diff --git a/lang/fortran/lib/libF77/d_tan.c b/lang/fortran/lib/libF77/d_tan.c new file mode 100644 index 000000000..f5e7adfcd --- /dev/null +++ b/lang/fortran/lib/libF77/d_tan.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double d_tan(x) +doublereal *x; +{ +double tan(); +return( tan(*x) ); +} diff --git a/lang/fortran/lib/libF77/d_tanh.c b/lang/fortran/lib/libF77/d_tanh.c new file mode 100644 index 000000000..6aca1a884 --- /dev/null +++ b/lang/fortran/lib/libF77/d_tanh.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double d_tanh(x) +doublereal *x; +{ +double tanh(); +return( tanh(*x) ); +} diff --git a/lang/fortran/lib/libF77/derf_.c b/lang/fortran/lib/libF77/derf_.c new file mode 100644 index 000000000..10a04eb45 --- /dev/null +++ b/lang/fortran/lib/libF77/derf_.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +double derf_(x) +doublereal *x; +{ +double erf(); + +return( erf(*x) ); +} diff --git a/lang/fortran/lib/libF77/derfc_.c b/lang/fortran/lib/libF77/derfc_.c new file mode 100644 index 000000000..c4d14ae11 --- /dev/null +++ b/lang/fortran/lib/libF77/derfc_.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +double derfc_(x) +doublereal *x; +{ +double erfc(); + +return( erfc(*x) ); +} diff --git a/lang/fortran/lib/libF77/ef1asc_.c b/lang/fortran/lib/libF77/ef1asc_.c new file mode 100644 index 000000000..b6077013c --- /dev/null +++ b/lang/fortran/lib/libF77/ef1asc_.c @@ -0,0 +1,15 @@ +/* EFL support routine to copy string b to string a */ + +#include "f2c.h" + +extern VOID s_copy(); + +#define M ( (long) (sizeof(long) - 1) ) +#define EVEN(x) ( ( (x)+ M) & (~M) ) + +VOID ef1asc_(a, la, b, lb) +int *a, *b; +long int *la, *lb; +{ +s_copy( (char *)a, (char *)b, EVEN(*la), *lb ); +} diff --git a/lang/fortran/lib/libF77/ef1cmc_.c b/lang/fortran/lib/libF77/ef1cmc_.c new file mode 100644 index 000000000..90cdc23ba --- /dev/null +++ b/lang/fortran/lib/libF77/ef1cmc_.c @@ -0,0 +1,12 @@ +/* EFL support routine to compare two character strings */ + +#include "f2c.h" + +extern integer s_cmp(); + +integer ef1cmc_(a, la, b, lb) +integer *a, *b; +integer *la, *lb; +{ +return( s_cmp( (char *)a, (char *)b, *la, *lb) ); +} diff --git a/lang/fortran/lib/libF77/erf_.c b/lang/fortran/lib/libF77/erf_.c new file mode 100644 index 000000000..4f19482dd --- /dev/null +++ b/lang/fortran/lib/libF77/erf_.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +double erf_(x) +real *x; +{ +double erf(); + +return( erf(*x) ); +} diff --git a/lang/fortran/lib/libF77/erfc_.c b/lang/fortran/lib/libF77/erfc_.c new file mode 100644 index 000000000..cbe0127d9 --- /dev/null +++ b/lang/fortran/lib/libF77/erfc_.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +double erfc_(x) +real *x; +{ +double erfc(); + +return( erfc(*x) ); +} diff --git a/lang/fortran/lib/libF77/getarg_.c b/lang/fortran/lib/libF77/getarg_.c new file mode 100644 index 000000000..849570f8c --- /dev/null +++ b/lang/fortran/lib/libF77/getarg_.c @@ -0,0 +1,27 @@ +#include "f2c.h" + +/* + * subroutine getarg(k, c) + * returns the kth unix command argument in fortran character + * variable argument c +*/ + +VOID getarg_(n, s, ls) +long int *n; +register char *s; +long int ls; +{ +extern int xargc; +extern char **xargv; +register char *t; +register int i; + +if(*n>=0 && *n= 0) + return(*x); +return(- *x); +} diff --git a/lang/fortran/lib/libF77/h_dim.c b/lang/fortran/lib/libF77/h_dim.c new file mode 100644 index 000000000..5ac3a0162 --- /dev/null +++ b/lang/fortran/lib/libF77/h_dim.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +extern integer s_cmp(); + +shortint h_dim(a,b) +shortint *a, *b; +{ +return( *a > *b ? *a - *b : 0); +} diff --git a/lang/fortran/lib/libF77/h_dnnt.c b/lang/fortran/lib/libF77/h_dnnt.c new file mode 100644 index 000000000..925225dfd --- /dev/null +++ b/lang/fortran/lib/libF77/h_dnnt.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +extern integer s_cmp(); + +shortint h_dnnt(x) +doublereal *x; +{ +double floor(); + +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} diff --git a/lang/fortran/lib/libF77/h_indx.c b/lang/fortran/lib/libF77/h_indx.c new file mode 100644 index 000000000..5b6d671b6 --- /dev/null +++ b/lang/fortran/lib/libF77/h_indx.c @@ -0,0 +1,26 @@ +#include "f2c.h" + +extern integer s_cmp(); + +shortint h_indx(a, b, la, lb) +char *a, *b; +long int la, lb; +{ +int i, n; +char *s, *t, *bend; + +n = la - lb + 1; +bend = b + lb; + +for(i = 0 ; i < n ; ++i) + { + s = a + i; + t = b; + while(t < bend) + if(*s++ != *t++) + goto no; + return(i+1); + no: ; + } +return(0); +} diff --git a/lang/fortran/lib/libF77/h_len.c b/lang/fortran/lib/libF77/h_len.c new file mode 100644 index 000000000..16c5baa4b --- /dev/null +++ b/lang/fortran/lib/libF77/h_len.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +extern integer s_cmp(); + +shortint h_len(s, n) +char *s; +long int n; +{ +return(n); +} diff --git a/lang/fortran/lib/libF77/h_mod.c b/lang/fortran/lib/libF77/h_mod.c new file mode 100644 index 000000000..dca0dfa31 --- /dev/null +++ b/lang/fortran/lib/libF77/h_mod.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +extern integer s_cmp(); + +shortint h_mod(a,b) +short *a, *b; +{ +return( *a % *b); +} diff --git a/lang/fortran/lib/libF77/h_nint.c b/lang/fortran/lib/libF77/h_nint.c new file mode 100644 index 000000000..0534d08ac --- /dev/null +++ b/lang/fortran/lib/libF77/h_nint.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +extern integer s_cmp(); + +shortint h_nint(x) +real *x; +{ +double floor(); + +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} diff --git a/lang/fortran/lib/libF77/h_sign.c b/lang/fortran/lib/libF77/h_sign.c new file mode 100644 index 000000000..5a0eb9431 --- /dev/null +++ b/lang/fortran/lib/libF77/h_sign.c @@ -0,0 +1,11 @@ +#include "f2c.h" + +extern integer s_cmp(); + +shortint h_sign(a,b) +shortint *a, *b; +{ +shortint x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} diff --git a/lang/fortran/lib/libF77/hl_ge.c b/lang/fortran/lib/libF77/hl_ge.c new file mode 100644 index 000000000..56c8cd2a8 --- /dev/null +++ b/lang/fortran/lib/libF77/hl_ge.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +extern integer s_cmp(); + +shortint hl_ge(a,b,la,lb) +char *a, *b; +long int la, lb; +{ +return(s_cmp(a,b,la,lb) >= 0); +} diff --git a/lang/fortran/lib/libF77/hl_gt.c b/lang/fortran/lib/libF77/hl_gt.c new file mode 100644 index 000000000..6587b4ef3 --- /dev/null +++ b/lang/fortran/lib/libF77/hl_gt.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +extern integer s_cmp(); + +shortint hl_gt(a,b,la,lb) +char *a, *b; +long int la, lb; +{ +return(s_cmp(a,b,la,lb) > 0); +} diff --git a/lang/fortran/lib/libF77/hl_le.c b/lang/fortran/lib/libF77/hl_le.c new file mode 100644 index 000000000..60d3ff295 --- /dev/null +++ b/lang/fortran/lib/libF77/hl_le.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +extern integer s_cmp(); + +shortint hl_le(a,b,la,lb) +char *a, *b; +long int la, lb; +{ +return(s_cmp(a,b,la,lb) <= 0); +} diff --git a/lang/fortran/lib/libF77/hl_lt.c b/lang/fortran/lib/libF77/hl_lt.c new file mode 100644 index 000000000..aee85c9d6 --- /dev/null +++ b/lang/fortran/lib/libF77/hl_lt.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +extern integer s_cmp(); + +shortint hl_lt(a,b,la,lb) +char *a, *b; +long int la, lb; +{ +return(s_cmp(a,b,la,lb) < 0); +} diff --git a/lang/fortran/lib/libF77/i_abs.c b/lang/fortran/lib/libF77/i_abs.c new file mode 100644 index 000000000..22135ce05 --- /dev/null +++ b/lang/fortran/lib/libF77/i_abs.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +integer i_abs(x) +integer *x; +{ +if(*x >= 0) + return(*x); +return(- *x); +} diff --git a/lang/fortran/lib/libF77/i_dim.c b/lang/fortran/lib/libF77/i_dim.c new file mode 100644 index 000000000..415ce308b --- /dev/null +++ b/lang/fortran/lib/libF77/i_dim.c @@ -0,0 +1,7 @@ +#include "f2c.h" + +integer i_dim(a,b) +integer *a, *b; +{ +return( *a > *b ? *a - *b : 0); +} diff --git a/lang/fortran/lib/libF77/i_dnnt.c b/lang/fortran/lib/libF77/i_dnnt.c new file mode 100644 index 000000000..15e61e911 --- /dev/null +++ b/lang/fortran/lib/libF77/i_dnnt.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +integer i_dnnt(x) +doublereal *x; +{ +double floor(); + +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} diff --git a/lang/fortran/lib/libF77/i_indx.c b/lang/fortran/lib/libF77/i_indx.c new file mode 100644 index 000000000..fb8576d2f --- /dev/null +++ b/lang/fortran/lib/libF77/i_indx.c @@ -0,0 +1,24 @@ +#include "f2c.h" + +integer i_indx(a, b, la, lb) +char *a, *b; +long int la, lb; +{ +long int i, n; +char *s, *t, *bend; + +n = la - lb + 1; +bend = b + lb; + +for(i = 0 ; i < n ; ++i) + { + s = a + i; + t = b; + while(t < bend) + if(*s++ != *t++) + goto no; + return(i+1); + no: ; + } +return(0); +} diff --git a/lang/fortran/lib/libF77/i_len.c b/lang/fortran/lib/libF77/i_len.c new file mode 100644 index 000000000..1c90f674c --- /dev/null +++ b/lang/fortran/lib/libF77/i_len.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +integer i_len(s, n) +char *s; +long int n; +{ +return(n); +} diff --git a/lang/fortran/lib/libF77/i_mod.c b/lang/fortran/lib/libF77/i_mod.c new file mode 100644 index 000000000..c80ee15e8 --- /dev/null +++ b/lang/fortran/lib/libF77/i_mod.c @@ -0,0 +1,7 @@ +#include "f2c.h" + +integer i_mod(a,b) +integer *a, *b; +{ +return( *a % *b); +} diff --git a/lang/fortran/lib/libF77/i_nint.c b/lang/fortran/lib/libF77/i_nint.c new file mode 100644 index 000000000..5a601f1ea --- /dev/null +++ b/lang/fortran/lib/libF77/i_nint.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +integer i_nint(x) +real *x; +{ +double floor(); + +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} diff --git a/lang/fortran/lib/libF77/i_sign.c b/lang/fortran/lib/libF77/i_sign.c new file mode 100644 index 000000000..87cb6539f --- /dev/null +++ b/lang/fortran/lib/libF77/i_sign.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +integer i_sign(a,b) +integer *a, *b; +{ +integer x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} diff --git a/lang/fortran/lib/libF77/iargc_.c b/lang/fortran/lib/libF77/iargc_.c new file mode 100644 index 000000000..bee7595c4 --- /dev/null +++ b/lang/fortran/lib/libF77/iargc_.c @@ -0,0 +1,7 @@ +#include "f2c.h" + +integer iargc_() +{ +extern int xargc; +return ( xargc - 1 ); +} diff --git a/lang/fortran/lib/libF77/l_ge.c b/lang/fortran/lib/libF77/l_ge.c new file mode 100644 index 000000000..73839364b --- /dev/null +++ b/lang/fortran/lib/libF77/l_ge.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +extern integer s_cmp(); + +integer l_ge(a,b,la,lb) +char *a, *b; +long int la, lb; +{ +return(s_cmp(a,b,la,lb) >= 0); +} diff --git a/lang/fortran/lib/libF77/l_gt.c b/lang/fortran/lib/libF77/l_gt.c new file mode 100644 index 000000000..1f468e7b6 --- /dev/null +++ b/lang/fortran/lib/libF77/l_gt.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +extern integer s_cmp(); + +integer l_gt(a,b,la,lb) +char *a, *b; +long int la, lb; +{ +return(s_cmp(a,b,la,lb) > 0); +} diff --git a/lang/fortran/lib/libF77/l_le.c b/lang/fortran/lib/libF77/l_le.c new file mode 100644 index 000000000..66a5c6386 --- /dev/null +++ b/lang/fortran/lib/libF77/l_le.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +extern integer s_cmp(); + +integer l_le(a,b,la,lb) +char *a, *b; +long int la, lb; +{ +return(s_cmp(a,b,la,lb) <= 0); +} diff --git a/lang/fortran/lib/libF77/l_lt.c b/lang/fortran/lib/libF77/l_lt.c new file mode 100644 index 000000000..708ef5671 --- /dev/null +++ b/lang/fortran/lib/libF77/l_lt.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +integer l_lt(a,b,la,lb) +char *a, *b; +long la, lb; +{ +return(s_cmp(a,b,la,lb) < 0); +} diff --git a/lang/fortran/lib/libF77/libF77.xsum b/lang/fortran/lib/libF77/libF77.xsum new file mode 100644 index 000000000..588638903 --- /dev/null +++ b/lang/fortran/lib/libF77/libF77.xsum @@ -0,0 +1,116 @@ +Notice fb5a412e 1183 +README 129e17de 902 +Version.c f4072818 752 +abort_.c 1ddc061a 123 +c_abs.c 3ccfc99 96 +c_cos.c 1d2a43cc 157 +c_div.c f08f5e0a 556 +c_exp.c f26ec4d4 165 +c_log.c ea713636 145 +c_sin.c eedb2a9 155 +c_sqrt.c e863dae 348 +cabs.c 514923b 309 +d_abs.c 8525b15 92 +d_acos.c e4d05af5 89 +d_asin.c f0d01384 89 +d_atan.c 1110dced 89 +d_atn2.c e098ae4 100 +d_cnjg.c e3e9622f 85 +d_cos.c ed9f8b7c 86 +d_cosh.c 19d05b3e 89 +d_dim.c e458c4ea 91 +d_exp.c ef428642 86 +d_imag.c c057bf1 71 +d_int.c 1e86e392 115 +d_lg10.c a976032 136 +d_log.c 4d50239 86 +d_mod.c ea39a739 415 +d_nint.c fcbb75a8 126 +d_prod.c 1a6760da 77 +d_sign.c f80806fe 124 +d_sin.c 4d62b63 86 +d_sinh.c e0c61add 89 +d_sqrt.c ec746103 89 +d_tan.c e19875b1 86 +d_tanh.c 1a4903ee 89 +derf_.c f82e7a98 87 +derfc_.c 17681562 90 +ef1asc_.c 10a294bd 285 +ef1cmc_.c e2000a1f 221 +erf_.c e51d2afe 80 +erfc_.c 1eeada84 83 +getarg_.c f7e5a7e2 415 +getenv_.c f2fbc977 881 +h_abs.c f17a9d28 117 +h_dim.c efa53d0c 116 +h_dnnt.c 1b6e30b4 153 +h_indx.c e541126 302 +h_len.c e5f0ba39 100 +h_mod.c e5070b30 99 +h_nint.c f2f6a9b6 147 +h_sign.c e0424bd3 151 +hl_ge.c f34d97c0 134 +hl_gt.c 1e9364c1 133 +hl_le.c 68dbb84 134 +hl_lt.c 3f5ec5a 133 +i_abs.c e9df85da 90 +i_dim.c f93e306f 89 +i_dnnt.c 1c51efb 127 +i_indx.c b222d76 281 +i_len.c 17926ad5 74 +i_mod.c 6b15148 75 +i_nint.c f3e91f29 121 +i_sign.c e8e073b2 123 +iargc_.c fd9410d9 79 +l_ge.c 1adab0fd 132 +l_gt.c e9f5bde3 131 +l_le.c ef1a9cb9 132 +l_lt.c fb4a7a8c 102 +main.c ef83b695 1362 +makefile ef8a327a 2943 +pow_ci.c 62b6caf 186 +pow_dd.c e1caeeb1 104 +pow_di.c ec10f0b0 325 +pow_hh.c e4161aa7 245 +pow_ii.c d0fbe46 242 +pow_ri.c fbdbece8 319 +pow_zi.c e87e82cc 518 +pow_zz.c fde95b82 312 +r_abs.c 1b85bc 86 +r_acos.c 11eeee20 83 +r_asin.c e7b27881 83 +r_atan.c 8920297 83 +r_atn2.c 4ac36c3 94 +r_cnjg.c e5db6724 84 +r_cos.c e07cb241 80 +r_cosh.c f51deb04 83 +r_dim.c 10a3ddd9 85 +r_exp.c 13e47ded 80 +r_imag.c 1703a645 65 +r_int.c c849cbb 109 +r_lg10.c 187b31e7 130 +r_log.c e5240928 80 +r_mod.c 7894f0d 417 +r_nint.c ff0c2044 120 +r_sign.c fc88b617 118 +r_sin.c 14626334 80 +r_sinh.c ea3a24ec 83 +r_sqrt.c e685c7f1 83 +r_tan.c ff2454a8 80 +r_tanh.c fa01b1c7 83 +s_cat.c 60770ce 294 +s_cmp.c 1aceca99 507 +s_copy.c 1783e78d 279 +s_paus.c f398b5e3 746 +s_rnge.c 7eaeb87 513 +s_stop.c f1f95e02 238 +sig_die.c f0fbd1a3 391 +signal_.c 1fd402d7 234 +system_.c 5d071f1 287 +z_abs.c f33e298 102 +z_cos.c 281d763 163 +z_div.c 8b4794a 547 +z_exp.c 1e060b77 171 +z_log.c f92a692d 153 +z_sin.c 8cb5ee6 161 +z_sqrt.c f0e4dfde 332 diff --git a/lang/fortran/lib/libF77/main.c b/lang/fortran/lib/libF77/main.c new file mode 100644 index 000000000..2ee506854 --- /dev/null +++ b/lang/fortran/lib/libF77/main.c @@ -0,0 +1,95 @@ +/* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */ + +#include "stdio.h" +#include "signal.h" + +#ifndef SIGIOT +#define SIGIOT SIGABRT +#endif + +#ifdef NO__STDC +#define ONEXIT onexit +extern void f_exit(); +#else +#ifdef __STDC__ +#include "stdlib.h" +extern void f_exit(void); +#ifndef NO_ONEXIT +#define ONEXIT atexit +extern int atexit(void (*)(void)); +#endif +#else +#ifndef NO_ONEXIT +#define ONEXIT onexit +extern void f_exit(); +#endif +#endif +#endif + +extern void sig_die(); + +static void sigfdie(n) +{ +sig_die("Floating Exception", 1); +} + + +static void sigidie(n) +{ +sig_die("IOT Trap", 1); +} + +#ifdef SIGQUIT +static void sigqdie(n) +{ +sig_die("Quit signal", 1); +} +#endif + + +static void sigindie(n) +{ +sig_die("Interrupt", 0); +} + + + +static void sigtdie(n) +{ +sig_die("Killed", 0); +} + + +int xargc; +char **xargv; + +main(argc, argv) +int argc; +char **argv; +{ +xargc = argc; +xargv = argv; +signal(SIGFPE, sigfdie); /* ignore underflow, enable overflow */ +signal(SIGIOT, sigidie); +#ifdef SIGQUIT +if(signal(SIGQUIT,sigqdie) == SIG_IGN) + signal(SIGQUIT, SIG_IGN); +#endif +if(signal(SIGINT, sigindie) == SIG_IGN) + signal(SIGINT, SIG_IGN); +signal(SIGTERM,sigtdie); + +#ifdef pdp11 + ldfps(01200); /* detect overflow as an exception */ +#endif + +f_init(); +#ifndef NO_ONEXIT +ONEXIT(f_exit); +#endif +MAIN__(); +#ifdef NO_ONEXIT +f_exit(); +#endif +exit(0); /* exit(0) rather than return(0) to bypass Cray bug */ +} diff --git a/lang/fortran/lib/libF77/makefile b/lang/fortran/lib/libF77/makefile new file mode 100644 index 000000000..b5c6df058 --- /dev/null +++ b/lang/fortran/lib/libF77/makefile @@ -0,0 +1,74 @@ +.SUFFIXES: .c .o +CC = cc +SHELL = /bin/sh + +# compile, then strip unnecessary symbols +.c.o: + $(CC) -O -c -DSkip_f2c_Undefs $*.c + ld -r -x $*.o + mv a.out $*.o + +MISC = Version.o main.o s_rnge.o abort_.o getarg_.o iargc_.o getenv_.o\ + signal_.o s_stop.o s_paus.o system_.o cabs.o\ + derf_.o derfc_.o erf_.o erfc_.o sig_die.o +POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o +CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o +DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o +REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\ + r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\ + r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\ + r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o +DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\ + d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\ + d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\ + d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\ + d_sqrt.o d_tan.o d_tanh.o +INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o +HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o +CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o +EFL = ef1asc_.o ef1cmc_.o +CHAR = s_cat.o s_cmp.o s_copy.o + +libF77.a : $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ + $(HALF) $(CMP) $(EFL) $(CHAR) + ar r libF77.a $? + ranlib libF77.a + +Version.o: Version.c + $(CC) -c Version.c + +# If your system lacks onexit() and you are not using an +# ANSI C compiler, then you should uncomment the following +# two lines (for compiling main.o): +#main.o: main.c +# $(CC) -c -DNO_ONEXIT -DSkip_f2c_Undefs main.c +# On at least some Sun systems, it is more appropriate to +# uncomment the following two lines: +#main.o: main.c +# $(CC) -c -Donexit=on_exit -DSkip_f2c_Undefs main.c + +install: libF77.a + mv libF77.a /usr/lib + +clean: + rm -f libF77.a *.o + +check: + xsum Notice README Version.c abort_.c c_abs.c c_cos.c c_div.c \ + c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c d_abs.c d_acos.c \ + d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c d_dim.c \ + d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c d_nint.c \ + d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c d_tanh.c \ + derf_.c derfc_.c ef1asc_.c ef1cmc_.c erf_.c erfc_.c getarg_.c \ + getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c h_mod.c \ + h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c i_abs.c \ + i_dim.c i_dnnt.c i_indx.c i_len.c i_mod.c i_nint.c i_sign.c \ + iargc_.c l_ge.c l_gt.c l_le.c l_lt.c main.c makefile pow_ci.c \ + pow_dd.c pow_di.c pow_hh.c pow_ii.c pow_ri.c pow_zi.c pow_zz.c \ + r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c r_cnjg.c r_cos.c \ + r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c r_log.c \ + r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c r_tan.c \ + r_tanh.c s_cat.c s_cmp.c s_copy.c s_paus.c s_rnge.c s_stop.c \ + sig_die.c signal_.c system_.c z_abs.c z_cos.c z_div.c z_exp.c \ + z_log.c z_sin.c z_sqrt.c >zap + cmp zap libF77.xsum && rm zap || diff libF77.xsum zap diff --git a/lang/fortran/lib/libF77/pow_ci.c b/lang/fortran/lib/libF77/pow_ci.c new file mode 100644 index 000000000..b0810a783 --- /dev/null +++ b/lang/fortran/lib/libF77/pow_ci.c @@ -0,0 +1,16 @@ +#include "f2c.h" + +VOID pow_ci(p, a, b) /* p = a**b */ +complex *p, *a; +integer *b; +{ +doublecomplex p1, a1; + +a1.r = a->r; +a1.i = a->i; + +pow_zi(&p1, &a1, b); + +p->r = p1.r; +p->i = p1.i; +} diff --git a/lang/fortran/lib/libF77/pow_dd.c b/lang/fortran/lib/libF77/pow_dd.c new file mode 100644 index 000000000..9caff078d --- /dev/null +++ b/lang/fortran/lib/libF77/pow_dd.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +double pow_dd(ap, bp) +doublereal *ap, *bp; +{ +double pow(); + +return(pow(*ap, *bp) ); +} diff --git a/lang/fortran/lib/libF77/pow_di.c b/lang/fortran/lib/libF77/pow_di.c new file mode 100644 index 000000000..9b1c4c557 --- /dev/null +++ b/lang/fortran/lib/libF77/pow_di.c @@ -0,0 +1,36 @@ +#include "f2c.h" + +double pow_di(ap, bp) +doublereal *ap; +integer *bp; +{ +double pow, x; +integer n; + +pow = 1; +x = *ap; +n = *bp; + +if(n != 0) + { + if(n < 0) + { + if(x == 0) + { + return(pow); + } + n = -n; + x = 1/x; + } + for( ; ; ) + { + if(n & 01) + pow *= x; + if(n >>= 1) + x *= x; + else + break; + } + } +return(pow); +} diff --git a/lang/fortran/lib/libF77/pow_hh.c b/lang/fortran/lib/libF77/pow_hh.c new file mode 100644 index 000000000..80e436ff4 --- /dev/null +++ b/lang/fortran/lib/libF77/pow_hh.c @@ -0,0 +1,25 @@ +#include "f2c.h" + +shortint pow_hh(ap, bp) +shortint *ap, *bp; +{ +shortint pow, x, n; + +pow = 1; +x = *ap; +n = *bp; + +if(n < 0) + { } +else if(n > 0) + for( ; ; ) + { + if(n & 01) + pow *= x; + if(n >>= 1) + x *= x; + else + break; + } +return(pow); +} diff --git a/lang/fortran/lib/libF77/pow_ii.c b/lang/fortran/lib/libF77/pow_ii.c new file mode 100644 index 000000000..238d27631 --- /dev/null +++ b/lang/fortran/lib/libF77/pow_ii.c @@ -0,0 +1,25 @@ +#include "f2c.h" + +integer pow_ii(ap, bp) +integer *ap, *bp; +{ +integer pow, x, n; + +pow = 1; +x = *ap; +n = *bp; + +if(n < 0) + { } +else if(n > 0) + for( ; ; ) + { + if(n & 01) + pow *= x; + if(n >>= 1) + x *= x; + else + break; + } +return(pow); +} diff --git a/lang/fortran/lib/libF77/pow_ri.c b/lang/fortran/lib/libF77/pow_ri.c new file mode 100644 index 000000000..f26422534 --- /dev/null +++ b/lang/fortran/lib/libF77/pow_ri.c @@ -0,0 +1,36 @@ +#include "f2c.h" + +double pow_ri(ap, bp) +real *ap; +integer *bp; +{ +double pow, x; +integer n; + +pow = 1; +x = *ap; +n = *bp; + +if(n != 0) + { + if(n < 0) + { + if(x == 0) + { + return(pow); + } + n = -n; + x = 1/x; + } + for( ; ; ) + { + if(n & 01) + pow *= x; + if(n >>= 1) + x *= x; + else + break; + } + } +return(pow); +} diff --git a/lang/fortran/lib/libF77/pow_zi.c b/lang/fortran/lib/libF77/pow_zi.c new file mode 100644 index 000000000..5bc32b1f0 --- /dev/null +++ b/lang/fortran/lib/libF77/pow_zi.c @@ -0,0 +1,46 @@ +#include "f2c.h" + +VOID pow_zi(p, a, b) /* p = a**b */ +doublecomplex *p, *a; +integer *b; +{ +integer n; +double t; +doublecomplex x; +static doublecomplex one = {1.0, 0.0}; + +n = *b; +p->r = 1; +p->i = 0; + +if(n == 0) + return; +if(n < 0) + { + n = -n; + z_div(&x, &one, a); + } +else + { + x.r = a->r; + x.i = a->i; + } + +for( ; ; ) + { + if(n & 01) + { + t = p->r * x.r - p->i * x.i; + p->i = p->r * x.i + p->i * x.r; + p->r = t; + } + if(n >>= 1) + { + t = x.r * x.r - x.i * x.i; + x.i = 2 * x.r * x.i; + x.r = t; + } + else + break; + } +} diff --git a/lang/fortran/lib/libF77/pow_zz.c b/lang/fortran/lib/libF77/pow_zz.c new file mode 100644 index 000000000..4708fcde6 --- /dev/null +++ b/lang/fortran/lib/libF77/pow_zz.c @@ -0,0 +1,17 @@ +#include "f2c.h" + +VOID pow_zz(r,a,b) +doublecomplex *r, *a, *b; +{ +double logr, logi, x, y; +double log(), exp(), cos(), sin(), atan2(), cabs(); + +logr = log( cabs(a->r, a->i) ); +logi = atan2(a->i, a->r); + +x = exp( logr * b->r - logi * b->i ); +y = logr * b->i + logi * b->r; + +r->r = x * cos(y); +r->i = x * sin(y); +} diff --git a/lang/fortran/lib/libF77/r_abs.c b/lang/fortran/lib/libF77/r_abs.c new file mode 100644 index 000000000..b169b853e --- /dev/null +++ b/lang/fortran/lib/libF77/r_abs.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +double r_abs(x) +real *x; +{ +if(*x >= 0) + return(*x); +return(- *x); +} diff --git a/lang/fortran/lib/libF77/r_acos.c b/lang/fortran/lib/libF77/r_acos.c new file mode 100644 index 000000000..86477b4e2 --- /dev/null +++ b/lang/fortran/lib/libF77/r_acos.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double r_acos(x) +real *x; +{ +double acos(); +return( acos(*x) ); +} diff --git a/lang/fortran/lib/libF77/r_asin.c b/lang/fortran/lib/libF77/r_asin.c new file mode 100644 index 000000000..8a07a971d --- /dev/null +++ b/lang/fortran/lib/libF77/r_asin.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double r_asin(x) +real *x; +{ +double asin(); +return( asin(*x) ); +} diff --git a/lang/fortran/lib/libF77/r_atan.c b/lang/fortran/lib/libF77/r_atan.c new file mode 100644 index 000000000..9ff38e7bb --- /dev/null +++ b/lang/fortran/lib/libF77/r_atan.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double r_atan(x) +real *x; +{ +double atan(); +return( atan(*x) ); +} diff --git a/lang/fortran/lib/libF77/r_atn2.c b/lang/fortran/lib/libF77/r_atn2.c new file mode 100644 index 000000000..608e82919 --- /dev/null +++ b/lang/fortran/lib/libF77/r_atn2.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double r_atn2(x,y) +real *x, *y; +{ +double atan2(); +return( atan2(*x,*y) ); +} diff --git a/lang/fortran/lib/libF77/r_cnjg.c b/lang/fortran/lib/libF77/r_cnjg.c new file mode 100644 index 000000000..680dfcf38 --- /dev/null +++ b/lang/fortran/lib/libF77/r_cnjg.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +VOID r_cnjg(r, z) +complex *r, *z; +{ +r->r = z->r; +r->i = - z->i; +} diff --git a/lang/fortran/lib/libF77/r_cos.c b/lang/fortran/lib/libF77/r_cos.c new file mode 100644 index 000000000..8f0663949 --- /dev/null +++ b/lang/fortran/lib/libF77/r_cos.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double r_cos(x) +real *x; +{ +double cos(); +return( cos(*x) ); +} diff --git a/lang/fortran/lib/libF77/r_cosh.c b/lang/fortran/lib/libF77/r_cosh.c new file mode 100644 index 000000000..64b8259a4 --- /dev/null +++ b/lang/fortran/lib/libF77/r_cosh.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double r_cosh(x) +real *x; +{ +double cosh(); +return( cosh(*x) ); +} diff --git a/lang/fortran/lib/libF77/r_dim.c b/lang/fortran/lib/libF77/r_dim.c new file mode 100644 index 000000000..2c9fcf245 --- /dev/null +++ b/lang/fortran/lib/libF77/r_dim.c @@ -0,0 +1,7 @@ +#include "f2c.h" + +double r_dim(a,b) +real *a, *b; +{ +return( *a > *b ? *a - *b : 0); +} diff --git a/lang/fortran/lib/libF77/r_exp.c b/lang/fortran/lib/libF77/r_exp.c new file mode 100644 index 000000000..ae51d7ac7 --- /dev/null +++ b/lang/fortran/lib/libF77/r_exp.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double r_exp(x) +real *x; +{ +double exp(); +return( exp(*x) ); +} diff --git a/lang/fortran/lib/libF77/r_imag.c b/lang/fortran/lib/libF77/r_imag.c new file mode 100644 index 000000000..a10f4f35b --- /dev/null +++ b/lang/fortran/lib/libF77/r_imag.c @@ -0,0 +1,7 @@ +#include "f2c.h" + +double r_imag(z) +complex *z; +{ +return(z->i); +} diff --git a/lang/fortran/lib/libF77/r_int.c b/lang/fortran/lib/libF77/r_int.c new file mode 100644 index 000000000..57c3dddbf --- /dev/null +++ b/lang/fortran/lib/libF77/r_int.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +double r_int(x) +real *x; +{ +double floor(); + +return( (*x>0) ? floor(*x) : -floor(- *x) ); +} diff --git a/lang/fortran/lib/libF77/r_lg10.c b/lang/fortran/lib/libF77/r_lg10.c new file mode 100644 index 000000000..d3be78e77 --- /dev/null +++ b/lang/fortran/lib/libF77/r_lg10.c @@ -0,0 +1,11 @@ +#include "f2c.h" + +#define log10e 0.43429448190325182765 + +double r_lg10(x) +real *x; +{ +double log(); + +return( log10e * log(*x) ); +} diff --git a/lang/fortran/lib/libF77/r_log.c b/lang/fortran/lib/libF77/r_log.c new file mode 100644 index 000000000..92cf25e89 --- /dev/null +++ b/lang/fortran/lib/libF77/r_log.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double r_log(x) +real *x; +{ +double log(); +return( log(*x) ); +} diff --git a/lang/fortran/lib/libF77/r_mod.c b/lang/fortran/lib/libF77/r_mod.c new file mode 100644 index 000000000..675a2c8f4 --- /dev/null +++ b/lang/fortran/lib/libF77/r_mod.c @@ -0,0 +1,26 @@ +#include "f2c.h" + +double r_mod(x,y) +real *x, *y; +{ +#ifdef IEEE_drem + double drem(), xa, ya, z; + if ((ya = *y) < 0.) + ya = -ya; + z = drem(xa = *x, ya); + if (xa > 0) { + if (z < 0) + z += ya; + } + else if (z > 0) + z -= ya; + return z; +#else + double floor(), quotient; + if( (quotient = (double)*x / *y) >= 0) + quotient = floor(quotient); + else + quotient = -floor(-quotient); + return(*x - (*y) * quotient ); +#endif +} diff --git a/lang/fortran/lib/libF77/r_nint.c b/lang/fortran/lib/libF77/r_nint.c new file mode 100644 index 000000000..142fd7af4 --- /dev/null +++ b/lang/fortran/lib/libF77/r_nint.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +double r_nint(x) +real *x; +{ +double floor(); + +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} diff --git a/lang/fortran/lib/libF77/r_sign.c b/lang/fortran/lib/libF77/r_sign.c new file mode 100644 index 000000000..2a9237df0 --- /dev/null +++ b/lang/fortran/lib/libF77/r_sign.c @@ -0,0 +1,9 @@ +#include "f2c.h" + +double r_sign(a,b) +real *a, *b; +{ +double x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} diff --git a/lang/fortran/lib/libF77/r_sin.c b/lang/fortran/lib/libF77/r_sin.c new file mode 100644 index 000000000..2d8bc8dce --- /dev/null +++ b/lang/fortran/lib/libF77/r_sin.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double r_sin(x) +real *x; +{ +double sin(); +return( sin(*x) ); +} diff --git a/lang/fortran/lib/libF77/r_sinh.c b/lang/fortran/lib/libF77/r_sinh.c new file mode 100644 index 000000000..b6d20e90d --- /dev/null +++ b/lang/fortran/lib/libF77/r_sinh.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double r_sinh(x) +real *x; +{ +double sinh(); +return( sinh(*x) ); +} diff --git a/lang/fortran/lib/libF77/r_sqrt.c b/lang/fortran/lib/libF77/r_sqrt.c new file mode 100644 index 000000000..e81c1e97e --- /dev/null +++ b/lang/fortran/lib/libF77/r_sqrt.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double r_sqrt(x) +real *x; +{ +double sqrt(); +return( sqrt(*x) ); +} diff --git a/lang/fortran/lib/libF77/r_tan.c b/lang/fortran/lib/libF77/r_tan.c new file mode 100644 index 000000000..0cd7e4ac3 --- /dev/null +++ b/lang/fortran/lib/libF77/r_tan.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double r_tan(x) +real *x; +{ +double tan(); +return( tan(*x) ); +} diff --git a/lang/fortran/lib/libF77/r_tanh.c b/lang/fortran/lib/libF77/r_tanh.c new file mode 100644 index 000000000..0f59111ae --- /dev/null +++ b/lang/fortran/lib/libF77/r_tanh.c @@ -0,0 +1,8 @@ +#include "f2c.h" + +double r_tanh(x) +real *x; +{ +double tanh(); +return( tanh(*x) ); +} diff --git a/lang/fortran/lib/libF77/s_cat.c b/lang/fortran/lib/libF77/s_cat.c new file mode 100644 index 000000000..573bb3f8a --- /dev/null +++ b/lang/fortran/lib/libF77/s_cat.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +VOID s_cat(lp, rpp, rnp, np, ll) +char *lp, *rpp[]; +ftnlen rnp[], *np, ll; +{ +int i, n, nc; +char *rp; + +n = *np; +for(i = 0 ; i < n ; ++i) + { + nc = ll; + if(rnp[i] < nc) + nc = rnp[i]; + ll -= nc; + rp = rpp[i]; + while(--nc >= 0) + *lp++ = *rp++; + } +while(--ll >= 0) + *lp++ = ' '; +} diff --git a/lang/fortran/lib/libF77/s_cmp.c b/lang/fortran/lib/libF77/s_cmp.c new file mode 100644 index 000000000..32de6dec6 --- /dev/null +++ b/lang/fortran/lib/libF77/s_cmp.c @@ -0,0 +1,38 @@ +#include "f2c.h" + +integer s_cmp(a, b, la, lb) /* compare two strings */ +register char *a, *b; +long int la, lb; +{ +register char *aend, *bend; +aend = a + la; +bend = b + lb; + +if(la <= lb) + { + while(a < aend) + if(*a != *b) + return( *a - *b ); + else + { ++a; ++b; } + + while(b < bend) + if(*b != ' ') + return( ' ' - *b ); + else ++b; + } + +else + { + while(b < bend) + if(*a == *b) + { ++a; ++b; } + else + return( *a - *b ); + while(a < aend) + if(*a != ' ') + return(*a - ' '); + else ++a; + } +return(0); +} diff --git a/lang/fortran/lib/libF77/s_copy.c b/lang/fortran/lib/libF77/s_copy.c new file mode 100644 index 000000000..59d45e41e --- /dev/null +++ b/lang/fortran/lib/libF77/s_copy.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +VOID s_copy(a, b, la, lb) /* assign strings: a = b */ +char *a, *b; +long int la, lb; +{ +char *aend, *bend; + +aend = a + la; + +if(la <= lb) + while(a < aend) + *a++ = *b++; + +else + { + bend = b + lb; + while(b < bend) + *a++ = *b++; + while(a < aend) + *a++ = ' '; + } +} diff --git a/lang/fortran/lib/libF77/s_paus.c b/lang/fortran/lib/libF77/s_paus.c new file mode 100644 index 000000000..789e45b85 --- /dev/null +++ b/lang/fortran/lib/libF77/s_paus.c @@ -0,0 +1,41 @@ +#include "stdio.h" +#include "f2c.h" +#define PAUSESIG 15 + +static waitpause() +{ +return; +} + +VOID s_paus(s, n) +char *s; +long int n; +{ +int i; + +fprintf(stderr, "PAUSE "); +if(n > 0) + for(i = 0; i 0) + { + fprintf(stderr, "STOP "); + for(i = 0; ir, z->i ) ); +} diff --git a/lang/fortran/lib/libF77/z_cos.c b/lang/fortran/lib/libF77/z_cos.c new file mode 100644 index 000000000..4a87e417e --- /dev/null +++ b/lang/fortran/lib/libF77/z_cos.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +VOID z_cos(r, z) +doublecomplex *r, *z; +{ +double sin(), cos(), sinh(), cosh(); + +r->r = cos(z->r) * cosh(z->i); +r->i = - sin(z->r) * sinh(z->i); +} diff --git a/lang/fortran/lib/libF77/z_div.c b/lang/fortran/lib/libF77/z_div.c new file mode 100644 index 000000000..cb8dd32df --- /dev/null +++ b/lang/fortran/lib/libF77/z_div.c @@ -0,0 +1,33 @@ +#include "f2c.h" + +extern VOID sig_die(); + +VOID z_div(c, a, b) +doublecomplex *a, *b, *c; +{ +double ratio, den; +double abr, abi; + +if( (abr = b->r) < 0.) + abr = - abr; +if( (abi = b->i) < 0.) + abi = - abi; +if( abr <= abi ) + { + if(abi == 0) + sig_die("complex division by zero", 1); + ratio = b->r / b->i ; + den = b->i * (1 + ratio*ratio); + c->r = (a->r*ratio + a->i) / den; + c->i = (a->i*ratio - a->r) / den; + } + +else + { + ratio = b->i / b->r ; + den = b->r * (1 + ratio*ratio); + c->r = (a->r + a->i*ratio) / den; + c->i = (a->i - a->r*ratio) / den; + } + +} diff --git a/lang/fortran/lib/libF77/z_exp.c b/lang/fortran/lib/libF77/z_exp.c new file mode 100644 index 000000000..cb1d7089a --- /dev/null +++ b/lang/fortran/lib/libF77/z_exp.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +VOID z_exp(r, z) +doublecomplex *r, *z; +{ +double expx; +double exp(), cos(), sin(); + +expx = exp(z->r); +r->r = expx * cos(z->i); +r->i = expx * sin(z->i); +} diff --git a/lang/fortran/lib/libF77/z_log.c b/lang/fortran/lib/libF77/z_log.c new file mode 100644 index 000000000..202766392 --- /dev/null +++ b/lang/fortran/lib/libF77/z_log.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +VOID z_log(r, z) +doublecomplex *r, *z; +{ +double log(), cabs(), atan2(); + +r->i = atan2(z->i, z->r); +r->r = log( cabs( z->r, z->i ) ); +} diff --git a/lang/fortran/lib/libF77/z_sin.c b/lang/fortran/lib/libF77/z_sin.c new file mode 100644 index 000000000..eee260546 --- /dev/null +++ b/lang/fortran/lib/libF77/z_sin.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +VOID z_sin(r, z) +doublecomplex *r, *z; +{ +double sin(), cos(), sinh(), cosh(); + +r->r = sin(z->r) * cosh(z->i); +r->i = cos(z->r) * sinh(z->i); +} diff --git a/lang/fortran/lib/libF77/z_sqrt.c b/lang/fortran/lib/libF77/z_sqrt.c new file mode 100644 index 000000000..b6195ae3f --- /dev/null +++ b/lang/fortran/lib/libF77/z_sqrt.c @@ -0,0 +1,22 @@ +#include "f2c.h" + +VOID z_sqrt(r, z) +doublecomplex *r, *z; +{ +double mag, sqrt(), cabs(); + +if( (mag = cabs(z->r, z->i)) == 0.) + r->r = r->i = 0.; +else if(z->r > 0) + { + r->r = sqrt(0.5 * (mag + z->r) ); + r->i = z->i / r->r / 2; + } +else + { + r->i = sqrt(0.5 * (mag - z->r) ); + if(z->i < 0) + z->i = - z->i; + r->r = z->i / r->i / 2; + } +} diff --git a/lang/fortran/lib/libI77/.distr b/lang/fortran/lib/libI77/.distr new file mode 100644 index 000000000..866b3077f --- /dev/null +++ b/lang/fortran/lib/libI77/.distr @@ -0,0 +1,42 @@ +LIST +Notice +README +Version.c +backspace.c +close.c +dfe.c +dolio.c +due.c +endfile.c +err.c +fio.h +fmt.c +fmt.h +fmtlib.c +fp.h +iio.c +ilnw.c +inquire.c +libI77.xsum +lio.h +local.h +lread.c +lwrite.c +makefile +open.c +rdfmt.c +rewind.c +rsfe.c +rsli.c +rsne.c +sfe.c +sue.c +typesize.c +uio.c +util.c +wref.c +wrtfmt.c +wsfe.c +wsle.c +wsne.c +xwsne.c diff --git a/lang/fortran/lib/libI77/LIST b/lang/fortran/lib/libI77/LIST new file mode 100644 index 000000000..1978cf830 --- /dev/null +++ b/lang/fortran/lib/libI77/LIST @@ -0,0 +1,37 @@ +Version.c +backspace.c +close.c +dfe.c +dolio.c +due.c +endfile.c +err.c +fio.h +fmt.c +fmt.h +fmtlib.c +fp.h +iio.c +ilnw.c +inquire.c +lio.h +local.h +lread.c +lwrite.c +open.c +rdfmt.c +rewind.c +rsfe.c +rsli.c +rsne.c +sfe.c +sue.c +typesize.c +uio.c +util.c +wref.c +wrtfmt.c +wsfe.c +wsle.c +wsne.c +xwsne.c diff --git a/lang/fortran/lib/libI77/Notice b/lang/fortran/lib/libI77/Notice new file mode 100644 index 000000000..ec5f903dc --- /dev/null +++ b/lang/fortran/lib/libI77/Notice @@ -0,0 +1,23 @@ +/**************************************************************** +Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + diff --git a/lang/fortran/lib/libI77/README b/lang/fortran/lib/libI77/README new file mode 100644 index 000000000..2020f2412 --- /dev/null +++ b/lang/fortran/lib/libI77/README @@ -0,0 +1,92 @@ +If your system lacks /usr/include/local.h , +then you should create an appropriate local.h in +this directory. An appropriate local.h may simply +be empty, or it may #define VAX or #define CRAY +(or whatever else you must do to make fp.h work right). +Alternatively, edit fp.h to suite your machine. + +If your system lacks /usr/include/fcntl.h , then you +should simply create an empty fcntl.h in this directory. + +If your system's sprintf does not work the way ANSI C +specifies -- specifically, if it does not return the +number of characters transmitted -- then insert the line + +#define USE_STRLEN + +at the end of fmt.h . This is necessary with +at least some versions of Sun software. + +If your system's fopen does not like the ANSI binary +reading and writing modes "rb" and "wb", then you should +compile open.c with NON_ANSI_RW_MODES #defined. + +If you get error messages about references to cf->_ptr +and cf->_base when compiling wrtfmt.c and wsfe.c or to +stderr->_flag when compiling err.c, then insert the line + +#define NON_UNIX_STDIO + +at the beginning of fio.h, and recompile these modules. + +You may need to supply the following non-ANSI routines: + + fstat(int fileds, struct stat *buf) is similar +to stat(char *name, struct stat *buf), except that +the first argument, fileds, is the file descriptor +returned by open rather than the name of the file. +fstat is used in the system-dependent routine +canseek (in the libI77 source file err.c), which +is supposed to return 1 if it's possible to issue +seeks on the file in question, 0 if it's not; you may +need to suitably modify err.c . On non-UNIX systems, +you can avoid references to fstat and stat by compiling +err.c, inquire.c, open.c, and util.c with MSDOS defined; +in that case, you may need to supply access(char *Name,0), +which is supposed to return 0 if file Name exists, +nonzero otherwise. + + char * mktemp(char *buf) is supposed to replace the +6 trailing X's in buf with a unique number and then +return buf. The idea is to get a unique name for +a temporary file. + +On non-UNIX systems, you may need to change a few other, +e.g.: the form of name computed by mktemp() in endfile.c and +open.c; the use of the open(), close(), and creat() system +calls in endfile.c, err.c, open.c; and the modes in calls on +fopen() and fdopen() (and perhaps the use of fdopen() itself +-- it's supposed to return a FILE* corresponding to a given +an integer file descriptor) in err.c and open.c (component ufmt +of struct unit is 1 for formatted I/O -- text mode on some systems +-- and 0 for unformatted I/O -- binary mode on some systems). + +For Turbo C++, in particular, you need to adjust the mktemp +invocations and should compile all of libI77 with -DMSDOS . +You also need to #undef ungetc in lread.c and rsne.c . +Don't use -mh -- it is horribly broken. + +If you want to be able to load against libI77 but not libF77, +then you will need to add sig_die.o (from libF77) to libI77. + +If you wish to use translated Fortran that has funny notions +of record length for direct unformatted I/O (i.e., that assumes +RECL= values in OPEN statements are not bytes but rather counts +of some other units -- e.g., 4-character words for VMS), then you +should insert an appropriate #define for url_Adjust at the +beginning of open.c . For VMS Fortran, for example, +#define url_Adjust(x) x *= 4 +would suffice. + +To check for transmission errors, issue the command + make check +This assumes you have the xsum program whose source, xsum.c, +is distributed as part of "all from f2c/src". If you do not +have xsum, you can obtain xsum.c by sending the following E-mail +message to netlib@research.att.com + send xsum.c from f2c/src + +The makefile assumes you have installed f2c.h in a standard +place (and does not cause recompilation when f2c.h is changed); +f2c.h comes with "all from f2c" (the source for f2c) and is +available separately ("f2c.h from f2c"). diff --git a/lang/fortran/lib/libI77/Version.c b/lang/fortran/lib/libI77/Version.c new file mode 100644 index 000000000..f297c7773 --- /dev/null +++ b/lang/fortran/lib/libI77/Version.c @@ -0,0 +1,94 @@ +static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 16 May 1991\n"; + +/* +2.01 $ format added +2.02 Coding bug in open.c repaired +2.03 fixed bugs in lread.c (read * with negative f-format) and lio.c + and lio.h (e-format conforming to spec) +2.04 changed open.c and err.c (fopen and freopen respectively) to + update to new c-library (append mode) +2.05 added namelist capability +2.06 allow internal list and namelist I/O +*/ + +/* +close.c: + allow upper-case STATUS= values +endfile.c + create fort.nnn if unit nnn not open; + else if (file length == 0) use creat() rather than copy; + use local copy() rather than forking /bin/cp; + rewind, fseek to clear buffer (for no reading past EOF) +err.c + use neither setbuf nor setvbuf; make stderr buffered +fio.h + #define _bufend +inquire.c + upper case responses; + omit byfile test from SEQUENTIAL= + answer "YES" to DIRECT= for unopened file (open to debate) +lio.c + flush stderr, stdout at end of each stmt + space before character strings in list output only at line start +lio.h + adjust LEW, LED consistent with old libI77 +lread.c + use atof() + allow "nnn*," when reading complex constants +open.c + try opening for writing when open for read fails, with + special uwrt value (2) delaying creat() to first write; + set curunit so error messages don't drop core; + no file name ==> fort.nnn except for STATUS='SCRATCH' +rdfmt.c + use atof(); trust EOF == end-of-file (so don't read past + end-of-file after endfile stmt) +sfe.c + flush stderr, stdout at end of each stmt +wrtfmt.c: + use upper case + put wrt_E and wrt_F into wref.c, use sprintf() + rather than ecvt() and fcvt() [more accurate on VAX] +*/ + +/* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */ + +/* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */ + +/* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */ +/* 29 Nov. 1989: change various int return types to long for f2c */ +/* 30 Nov. 1989: various types from f2c.h */ +/* 6 Dec. 1989: types corrected various places */ +/* 19 Dec. 1989: make iostat= work right for internal I/O */ +/* 8 Jan. 1990: add rsne, wsne -- routines for handling NAMELIST */ +/* 28 Jan. 1990: have NAMELIST read treat $ as &, general white + space as blank */ +/* 27 Mar. 1990: change an = to == in rd_L(rdfmt.c) so formatted reads + of logical values reject letters other than fFtT; + have nowwriting reset cf */ +/* 14 Aug. 1990: adjust lread.c to treat tabs as spaces in list input */ +/* 17 Aug. 1990: adjust open.c to recognize blank='Z...' as well as + blank='z...' when reopening an open file */ +/* 30 Aug. 1990: prevent embedded blanks in list output of complex values; + omit exponent field in list output of values of + magnitude between 10 and 1e8; prevent writing stdin + and reading stdout or stderr; don't close stdin, stdout, + or stderr when reopening units 5, 6, 0. */ +/* 18 Sep. 1990: add component udev to unit and consider old == new file + iff uinode and udev values agree; use stat rather than + access to check existence of file (when STATUS='OLD')*/ +/* 2 Oct. 1990: adjust rewind.c so two successive rewinds after a write + don't clobber the file. */ +/* 9 Oct. 1990: add #include "fcntl.h" to endfile.c, err.c, open.c; + adjust g_char in util.c for segmented memories. */ +/* 17 Oct. 1990: replace abort() and _cleanup() with calls on + sig_die(...,1) (defined in main.c). */ +/* 5 Nov. 1990: changes to open.c: complain if new= is specified and the + file already exists; allow file= to be omitted in open stmts + and allow status='replace' (Fortran 90 extensions). */ +/* 11 Dec. 1990: adjustments for POSIX. */ +/* 15 Jan. 1991: tweak i_ungetc in rsli.c to allow reading from + strings in read-only memory. */ +/* 25 Apr. 1991: adjust namelist stuff to work with f2c -i2 */ +/* 26 Apr. 1991: fix some bugs with NAMELIST read of multi-dim. arrays */ +/* 16 May 1991: increase LEFBL in lio.h to bypass NeXT bug */ diff --git a/lang/fortran/lib/libI77/backspace.c b/lang/fortran/lib/libI77/backspace.c new file mode 100644 index 000000000..e5ecf72e7 --- /dev/null +++ b/lang/fortran/lib/libI77/backspace.c @@ -0,0 +1,63 @@ +#include "f2c.h" +#include "fio.h" +integer f_back(a) alist *a; +{ unit *b; + int n,i; + long x; + char buf[32]; + if(a->aunit >= MXUNIT || a->aunit < 0) + err(a->aerr,101,"backspace") + b= &units[a->aunit]; + if(b->useek==0) err(a->aerr,106,"backspace") + if(b->ufd==NULL) { + fk_open(1, 1, a->aunit); + return(0); + } + if(b->uend==1) + { b->uend=0; + return(0); + } + if(b->uwrt) { + (void) t_runc(a); + if (nowreading(b)) + err(a->aerr,errno,"backspace") + } + if(b->url>0) + { long y; + x=ftell(b->ufd); + y = x % b->url; + if(y == 0) x--; + x /= b->url; + x *= b->url; + (void) fseek(b->ufd,x,SEEK_SET); + return(0); + } + + if(b->ufmt==0) + { (void) fseek(b->ufd,-(long)sizeof(int),SEEK_CUR); + (void) fread((char *)&n,sizeof(int),1,b->ufd); + (void) fseek(b->ufd,-(long)n-2*sizeof(int),SEEK_CUR); + return(0); + } + for(;;) + { long y; + y = x=ftell(b->ufd); + if(xufd,x,SEEK_SET); + n=fread(buf,1,(int)(y-x), b->ufd); + for(i=n-2;i>=0;i--) + { + if(buf[i]!='\n') continue; + (void) fseek(b->ufd,(long)(i+1-n),SEEK_CUR); + return(0); + } + if(x==0) + { + (void) fseek(b->ufd, 0L, SEEK_SET); + return(0); + } + else if(n<=0) err(a->aerr,(EOF),"backspace") + (void) fseek(b->ufd, x, SEEK_SET); + } +} diff --git a/lang/fortran/lib/libI77/close.c b/lang/fortran/lib/libI77/close.c new file mode 100644 index 000000000..ee5a64fca --- /dev/null +++ b/lang/fortran/lib/libI77/close.c @@ -0,0 +1,59 @@ +#include "f2c.h" +#include "fio.h" +integer f_clos(a) cllist *a; +{ unit *b; + if(a->cunit >= MXUNIT) return(0); + b= &units[a->cunit]; + if(b->ufd==NULL) + goto done; + if (!a->csta) + if (b->uscrtch == 1) + goto delete; + else + goto keep; + switch(*a->csta) { + default: + keep: + case 'k': + case 'K': + if(b->uwrt == 1) + (void) t_runc((alist *)a); + if(b->ufnm) { + (void) fclose(b->ufd); + free(b->ufnm); + } + break; + case 'd': + case 'D': + delete: + if(b->ufnm) { + (void) fclose(b->ufd); + (void) unlink(b->ufnm); /*SYSDEP*/ + free(b->ufnm); + } + } + b->ufd=NULL; + done: + b->uend=0; + b->ufnm=NULL; + return(0); + } + void +f_exit() +{ int i; + static cllist xx; + if (!xx.cerr) { + xx.cerr=1; + xx.csta=NULL; + for(i=0;iuwrt && nowreading(curunit)) + err(a->cierr,errno,"read start"); + getn = y_getc; + doed = rd_ed; + doned = rd_ned; + dorevert = donewrec = y_err; + doend = y_rsk; + if(pars_f(fmtbuf)<0) + err(a->cierr,100,"read start"); + fmt_bg(); + return(0); +} +integer s_wdfe(a) cilist *a; +{ + int n; + if(!init) f_init(); + if(n=c_dfe(a)) return(n); + reading=0; + if(curunit->uwrt != 1 && nowwriting(curunit)) + err(a->cierr,errno,"startwrt"); + putn = y_putc; + doed = w_ed; + doned= w_ned; + dorevert = y_err; + donewrec = y_newrec; + doend = y_rev; + if(pars_f(fmtbuf)<0) + err(a->cierr,100,"startwrt"); + fmt_bg(); + return(0); +} +integer e_rdfe() +{ + (void) en_fio(); + return(0); +} +integer e_wdfe() +{ + (void) en_fio(); + return(0); +} +c_dfe(a) cilist *a; +{ + sequential=0; + formatted=external=1; + elist=a; + cursor=scale=recpos=0; + if(a->ciunit>MXUNIT || a->ciunit<0) + err(a->cierr,101,"startchk"); + curunit = &units[a->ciunit]; + if(curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit)) + err(a->cierr,104,"dfe"); + cf=curunit->ufd; + if(!curunit->ufmt) err(a->cierr,102,"dfe") + if(!curunit->useek) err(a->cierr,104,"dfe") + fmtbuf=a->cifmt; + (void) fseek(cf,(long)curunit->url * (a->cirec-1),SEEK_SET); + curunit->uend = 0; + return(0); +} +y_rsk() +{ + if(curunit->uend || curunit->url <= recpos + || curunit->url == 1) return 0; + do { + getc(cf); + } while(++recpos < curunit->url); + return 0; +} +y_getc() +{ + int ch; + if(curunit->uend) return(-1); + if((ch=getc(cf))!=EOF) + { + recpos++; + if(curunit->url>=recpos || + curunit->url==1) + return(ch); + else return(' '); + } + if(feof(cf)) + { + curunit->uend=1; + errno=0; + return(-1); + } + err(elist->cierr,errno,"readingd"); +} +y_putc(c) +{ + recpos++; + if(recpos <= curunit->url || curunit->url==1) + putc(c,cf); + else + err(elist->cierr,110,"dout"); + return(0); +} +y_rev() +{ /*what about work done?*/ + if(curunit->url==1 || recpos==curunit->url) + return(0); + while(recposurl) + (*putn)(' '); + recpos=0; + return(0); +} +y_err() +{ + err(elist->cierr, 110, "dfe"); +} + +y_newrec() +{ + if(curunit->url == 1 || recpos == curunit->url) { + hiwater = recpos = cursor = 0; + return(1); + } + if(hiwater > recpos) + recpos = hiwater; + y_rev(); + hiwater = cursor = 0; + return(1); +} diff --git a/lang/fortran/lib/libI77/dolio.c b/lang/fortran/lib/libI77/dolio.c new file mode 100644 index 000000000..5f14ddb82 --- /dev/null +++ b/lang/fortran/lib/libI77/dolio.c @@ -0,0 +1,7 @@ +#include "f2c.h" +extern int (*lioproc)(); + +integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len; +{ + return((*lioproc)(number,ptr,len,*type)); +} diff --git a/lang/fortran/lib/libI77/due.c b/lang/fortran/lib/libI77/due.c new file mode 100644 index 000000000..31d2cc613 --- /dev/null +++ b/lang/fortran/lib/libI77/due.c @@ -0,0 +1,51 @@ +#include "f2c.h" +#include "fio.h" +integer s_rdue(a) cilist *a; +{ + int n; + if(n=c_due(a)) return(n); + reading=1; + if(curunit->uwrt && nowreading(curunit)) + err(a->cierr,errno,"read start"); + return(0); +} +integer s_wdue(a) cilist *a; +{ + int n; + if(n=c_due(a)) return(n); + reading=0; + if(curunit->uwrt != 1 && nowwriting(curunit)) + err(a->cierr,errno,"write start"); + return(0); +} +c_due(a) cilist *a; +{ + if(!init) f_init(); + if(a->ciunit>=MXUNIT || a->ciunit<0) + err(a->cierr,101,"startio"); + recpos=sequential=formatted=0; + external=1; + curunit = &units[a->ciunit]; + elist=a; + if(curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due"); + cf=curunit->ufd; + if(curunit->ufmt) err(a->cierr,102,"cdue") + if(!curunit->useek) err(a->cierr,104,"cdue") + if(curunit->ufd==NULL) err(a->cierr,114,"cdue") + (void) fseek(cf,(long)(a->cirec-1)*curunit->url,SEEK_SET); + curunit->uend = 0; + return(0); +} +integer e_rdue() +{ + if(curunit->url==1 || recpos==curunit->url) + return(0); + (void) fseek(cf,(long)(curunit->url-recpos),SEEK_CUR); + if(ftell(cf)%curunit->url) + err(elist->cierr,200,"syserr"); + return(0); +} +integer e_wdue() +{ + return(e_rdue()); +} diff --git a/lang/fortran/lib/libI77/endfile.c b/lang/fortran/lib/libI77/endfile.c new file mode 100644 index 000000000..99a4e09f2 --- /dev/null +++ b/lang/fortran/lib/libI77/endfile.c @@ -0,0 +1,83 @@ +#include "f2c.h" +#include "fio.h" +#include "sys/types.h" +#include "fcntl.h" +#ifndef O_RDONLY +#define O_RDONLY 0 +#endif + +extern char *mktemp(), *strcpy(); + +integer f_end(a) alist *a; +{ + unit *b; + if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile"); + b = &units[a->aunit]; + if(b->ufd==NULL) { + char nbuf[10]; + (void) sprintf(nbuf,"fort.%ld",a->aunit); + close(creat(nbuf, 0666)); + return(0); + } + b->uend=1; + return(b->useek ? t_runc(a) : 0); +} + + static int +copy(from, len, to) + char *from, *to; + register long len; +{ + register int n; + int k, rc = 0, tmp; + char buf[BUFSIZ]; + + if ((k = open(from, O_RDONLY)) < 0) + return 1; + if ((tmp = creat(to,0666)) < 0) + return 1; + while((n = read(k, buf, len > BUFSIZ ? BUFSIZ : (int)len)) > 0) { + if (write(tmp, buf, n) != n) + { rc = 1; break; } + if ((len -= n) <= 0) + break; + } + close(k); + close(tmp); + return n < 0 ? 1 : rc; + } + +t_runc(a) alist *a; +{ + char nm[16]; + long loc, len; + unit *b; + int rc = 0; + + b = &units[a->aunit]; + if(b->url) return(0); /*don't truncate direct files*/ + loc=ftell(b->ufd); + (void) fseek(b->ufd,0L,SEEK_END); + len=ftell(b->ufd); + if (loc >= len || b->useek == 0 || b->ufnm == NULL) + return(0); + rewind(b->ufd); /* empty buffer */ + if (!loc) { + if (close(creat(b->ufnm,0666))) + { rc = 1; goto done; } + if (b->uwrt) + b->uwrt = 1; + return 0; + } + (void) strcpy(nm,"tmp.FXXXXXX"); + (void) mktemp(nm); + if (copy(b->ufnm, loc, nm) + || copy(nm, loc, b->ufnm)) + rc = 1; + unlink(nm); +done: + fseek(b->ufd, loc, SEEK_SET); + if (rc) + err(a->aerr,111,"endfile"); + return 0; + } diff --git a/lang/fortran/lib/libI77/err.c b/lang/fortran/lib/libI77/err.c new file mode 100644 index 000000000..1dae37759 --- /dev/null +++ b/lang/fortran/lib/libI77/err.c @@ -0,0 +1,223 @@ +#include "sys/types.h" +#ifndef MSDOS +#include "sys/stat.h" +#endif +#include "f2c.h" +#include "fio.h" +#include "fcntl.h" +#ifndef O_WRONLY +#define O_WRONLY 1 +#endif + +extern FILE *fdopen(); + +/*global definitions*/ +unit units[MXUNIT]; /*unit table*/ +flag init; /*0 on entry, 1 after initializations*/ +cilist *elist; /*active external io list*/ +flag reading; /*1 if reading, 0 if writing*/ +flag cplus,cblank; +char *fmtbuf; +flag external; /*1 if external io, 0 if internal */ +int (*doed)(),(*doned)(); +int (*doend)(),(*donewrec)(),(*dorevert)(); +flag sequential; /*1 if sequential io, 0 if direct*/ +flag formatted; /*1 if formatted io, 0 if unformatted*/ +int (*getn)(),(*putn)(); /*for formatted io*/ +FILE *cf; /*current file*/ +unit *curunit; /*current unit*/ +int recpos; /*place in current record*/ +int cursor,scale; + +/*error messages*/ +char *F_err[] = +{ + "error in format", /* 100 */ + "illegal unit number", /* 101 */ + "formatted io not allowed", /* 102 */ + "unformatted io not allowed", /* 103 */ + "direct io not allowed", /* 104 */ + "sequential io not allowed", /* 105 */ + "can't backspace file", /* 106 */ + "null file name", /* 107 */ + "can't stat file", /* 108 */ + "unit not connected", /* 109 */ + "off end of record", /* 110 */ + "truncation failed in endfile", /* 111 */ + "incomprehensible list input", /* 112 */ + "out of free space", /* 113 */ + "unit not connected", /* 114 */ + "read unexpected character", /* 115 */ + "bad logical input field", /* 116 */ + "bad variable type", /* 117 */ + "bad namelist name", /* 118 */ + "variable not in namelist", /* 119 */ + "no end record", /* 120 */ + "variable count incorrect", /* 121 */ + "subscript for scalar variable", /* 122 */ + "invalid array section", /* 123 */ + "substring out of bounds", /* 124 */ + "subscript out of bounds", /* 125 */ + "can't read file", /* 126 */ + "can't write file", /* 127 */ + "'new' file exists" /* 128 */ +}; +#define MAXERR (sizeof(F_err)/sizeof(char *)+100) +fatal(n,s) char *s; +{ + if(n<100 && n>=0) perror(s); /*SYSDEP*/ + else if(n >= (int)MAXERR || n < -1) + { fprintf(stderr,"%s: illegal error number %d\n",s,n); + } + else if(n == -1) fprintf(stderr,"%s: end of file\n",s); + else + fprintf(stderr,"%s: %s\n",s,F_err[n-100]); + if (curunit) { + fprintf(stderr,"apparent state: unit %d ",curunit-units); + fprintf(stderr, curunit->ufnm ? "named %s\n" : "(unnamed)\n", + curunit->ufnm); + } + else + fprintf(stderr,"apparent state: internal I/O\n"); + if (fmtbuf) + fprintf(stderr,"last format: %s\n",fmtbuf); + fprintf(stderr,"lately %s %s %s %s",reading?"reading":"writing", + sequential?"sequential":"direct",formatted?"formatted":"unformatted", + external?"external":"internal"); + sig_die(" IO", 1); +} +/*initialization routine*/ +f_init() +{ unit *p; + + init=1; + p= &units[0]; + p->ufd=stderr; + p->useek=canseek(stderr); +#ifdef COMMENTED_OUT + if(isatty(fileno(stderr))) { + extern char *malloc(); + setbuf(stderr, malloc(BUFSIZ)); + /* setvbuf(stderr, _IOLBF, 0, 0); */ + } /* wastes space, but win for debugging in windows */ +#endif +#ifdef NON_UNIX_STDIO + {extern char *malloc(); setbuf(stderr, malloc(BUFSIZ));} +#else + stderr->_flag &= ~_IONBF; +#endif + p->ufmt=1; + p->uwrt=1; + p = &units[5]; + p->ufd=stdin; + p->useek=canseek(stdin); + p->ufmt=1; + p->uwrt=0; + p= &units[6]; + p->ufd=stdout; + p->useek=canseek(stdout); + /* IOLBUF and setvbuf only in system 5+ */ +#ifdef COMMENTED_OUT + if(isatty(fileno(stdout))) { + extern char _sobuf[]; + setbuf(stdout, _sobuf); + /* setvbuf(stdout, _IOLBF, 0, 0); /* the buf arg in setvbuf? */ + p->useek = 1; /* only within a record no bigger than BUFSIZ */ + } +#endif + p->ufmt=1; + p->uwrt=1; +} +canseek(f) FILE *f; /*SYSDEP*/ +{ +#ifdef MSDOS + return !isatty(fileno(f)); +#else + struct stat x; + + if (fstat(fileno(f),&x) < 0) + return(0); +#ifdef S_IFMT + switch(x.st_mode & S_IFMT) { + case S_IFDIR: + case S_IFREG: + if(x.st_nlink > 0) /* !pipe */ + return(1); + else + return(0); + case S_IFCHR: + if(isatty(fileno(f))) + return(0); + return(1); +#ifdef S_IFBLK + case S_IFBLK: + return(1); +#endif + } +#else +#ifdef S_ISDIR + /* POSIX version */ + if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) { + if(x.st_nlink > 0) /* !pipe */ + return(1); + else + return(0); + } + if (S_ISCHR(x.st_mode)) { + if(isatty(fileno(f))) + return(0); + return(1); + } + if (S_ISBLK(x.st_mode)) + return(1); +#else + Help! How does fstat work on this system? +#endif +#endif + return(0); /* who knows what it is? */ +#endif +} +nowreading(x) unit *x; +{ + long loc; + extern char *r_mode[]; + if (!x->ufnm) + goto cantread; + loc=ftell(x->ufd); + if(freopen(x->ufnm,r_mode[x->ufmt],x->ufd) == NULL) { + cantread: + errno = 126; + return(1); + } + x->uwrt=0; + (void) fseek(x->ufd,loc,SEEK_SET); + return(0); +} +nowwriting(x) unit *x; +{ + long loc; + int k; + extern char *w_mode[]; + + if (!x->ufnm) + goto cantwrite; + if (x->uwrt == 3) { /* just did write, rewind */ + if (close(creat(x->ufnm,0666))) + goto cantwrite; + } + else { + loc=ftell(x->ufd); + if (fclose(x->ufd) < 0 + || (k = x->uwrt == 2 ? creat(x->ufnm,0666) + : open(x->ufnm,O_WRONLY)) < 0 + || (cf = x->ufd = fdopen(k,w_mode[x->ufmt])) == NULL) { + x->ufd = NULL; + cantwrite: + errno = 127; + return(1); + } + (void) fseek(x->ufd,loc,SEEK_SET); + } + x->uwrt = 1; + return(0); +} diff --git a/lang/fortran/lib/libI77/fio.h b/lang/fortran/lib/libI77/fio.h new file mode 100644 index 000000000..44d4547fa --- /dev/null +++ b/lang/fortran/lib/libI77/fio.h @@ -0,0 +1,65 @@ +#include "stdio.h" +#ifndef NULL +/* ANSI C */ +#include "stddef.h" +#endif + +#ifndef SEEK_SET +#define SEEK_SET 0 +#define SEEK_CUR 1 +#define SEEK_END 2 +#endif + +#ifdef MSDOS +#ifndef NON_UNIX_STDIO +#define NON_UNIX_STDIO +#endif +#endif + +/*units*/ +typedef struct +{ FILE *ufd; /*0=unconnected*/ + char *ufnm; +#ifndef MSDOS + long uinode; + int udev; +#endif + int url; /*0=sequential*/ + flag useek; /*true=can backspace, use dir, ...*/ + flag ufmt; + flag uprnt; + flag ublnk; + flag uend; + flag uwrt; /*last io was write*/ + flag uscrtch; +} unit; + +extern int errno; +extern flag init; +extern cilist *elist; /*active external io list*/ +extern flag reading,external,sequential,formatted; +extern int (*getn)(),(*putn)(); /*for formatted io*/ +extern long inode(); +extern FILE *cf; /*current file*/ +extern unit *curunit; /*current unit*/ +extern unit units[]; +extern VOID sig_die(); +#define err(f,m,s) {if(f) errno= m; else fatal(m,s); return(m);} + +/*Table sizes*/ +#define MXUNIT 100 + +extern int recpos; /*position in current record*/ +extern int cursor; /* offset to move to */ +extern int hiwater; /* so TL doesn't confuse us */ + +#define WRITE 1 +#define READ 2 +#define SEQ 3 +#define DIR 4 +#define FMT 5 +#define UNF 6 +#define EXT 7 +#define INT 8 + +#define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ) diff --git a/lang/fortran/lib/libI77/fmt.c b/lang/fortran/lib/libI77/fmt.c new file mode 100644 index 000000000..e940fcbb0 --- /dev/null +++ b/lang/fortran/lib/libI77/fmt.c @@ -0,0 +1,434 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#define skip(s) while(*s==' ') s++ +#ifdef interdata +#define SYLMX 300 +#endif +#ifdef pdp11 +#define SYLMX 300 +#endif +#ifdef vax +#define SYLMX 300 +#endif +#ifndef SYLMX +#define SYLMX 300 +#endif +#define GLITCH '\2' + /* special quote character for stu */ +extern int cursor,scale; +extern flag cblank,cplus; /*blanks in I and compulsory plus*/ +struct syl syl[SYLMX]; +int parenlvl,pc,revloc; + +char *f_s(),*f_list(),*i_tem(),*gt_num(); + +pars_f(s) char *s; +{ + parenlvl=revloc=pc=0; + if(f_s(s,0) == NULL) + { + return(-1); + } + return(0); +} +char *f_s(s,curloc) char *s; +{ + skip(s); + if(*s++!='(') + { + return(NULL); + } + if(parenlvl++ ==1) revloc=curloc; + if(op_gen(RET,curloc,0,0)<0 || + (s=f_list(s))==NULL) + { + return(NULL); + } + skip(s); + return(s); +} +char *f_list(s) char *s; +{ + for(;*s!=0;) + { skip(s); + if((s=i_tem(s))==NULL) return(NULL); + skip(s); + if(*s==',') s++; + else if(*s==')') + { if(--parenlvl==0) + { + (void) op_gen(REVERT,revloc,0,0); + return(++s); + } + (void) op_gen(GOTO,0,0,0); + return(++s); + } + } + return(NULL); +} +char *i_tem(s) char *s; +{ char *t; + int n,curloc; + if(*s==')') return(s); + if(ne_d(s,&t)) return(t); + if(e_d(s,&t)) return(t); + s=gt_num(s,&n); + if((curloc=op_gen(STACK,n,0,0))<0) return(NULL); + return(f_s(s,curloc)); +} +ne_d(s,p) char *s,**p; +{ int n,x,sign=0; + char *ap_end(); + struct syl *sp; + switch(*s) + { + default: + return(0); + case ':': (void) op_gen(COLON,0,0,0); break; + case '$': + (void) op_gen(NONL, 0, 0, 0); break; + case 'B': + case 'b': + if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0); + else (void) op_gen(BN,0,0,0); + break; + case 'S': + case 's': + if(*(s+1)=='s' || *(s+1) == 'S') + { x=SS; + s++; + } + else if(*(s+1)=='p' || *(s+1) == 'P') + { x=SP; + s++; + } + else x=S; + (void) op_gen(x,0,0,0); + break; + case '/': (void) op_gen(SLASH,0,0,0); break; + case '-': sign=1; + case '+': s++; /*OUTRAGEOUS CODING TRICK*/ + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + s=gt_num(s,&n); + switch(*s) + { + default: + return(0); + case 'P': + case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break; + case 'X': + case 'x': (void) op_gen(X,n,0,0); break; + case 'H': + case 'h': + sp = &syl[op_gen(H,n,0,0)]; + *(char **)&sp->p2 = s + 1; + s+=n; + break; + } + break; + case GLITCH: + case '"': + case '\'': + sp = &syl[op_gen(APOS,0,0,0)]; + *(char **)&sp->p2 = s; + if((*p = ap_end(s)) == NULL) + return(0); + return(1); + case 'T': + case 't': + if(*(s+1)=='l' || *(s+1) == 'L') + { x=TL; + s++; + } + else if(*(s+1)=='r'|| *(s+1) == 'R') + { x=TR; + s++; + } + else x=T; + s=gt_num(s+1,&n); + s--; + (void) op_gen(x,n,0,0); + break; + case 'X': + case 'x': (void) op_gen(X,1,0,0); break; + case 'P': + case 'p': (void) op_gen(P,1,0,0); break; + } + s++; + *p=s; + return(1); +} +e_d(s,p) char *s,**p; +{ int n,w,d,e,found=0,x=0; + char *sv=s; + s=gt_num(s,&n); + (void) op_gen(STACK,n,0,0); + switch(*s++) + { + default: break; + case 'E': + case 'e': x=1; + case 'G': + case 'g': + found=1; + s=gt_num(s,&w); + if(w==0) break; + if(*s=='.') + { s++; + s=gt_num(s,&d); + } + else d=0; + if(*s!='E' && *s != 'e') + (void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */ + else + { s++; + s=gt_num(s,&e); + (void) op_gen(x==1?EE:GE,w,d,e); + } + break; + case 'O': + case 'o': + found = 1; + s = gt_num(s, &w); + if(w==0) break; + (void) op_gen(O, w, 0, 0); + break; + case 'L': + case 'l': + found=1; + s=gt_num(s,&w); + if(w==0) break; + (void) op_gen(L,w,0,0); + break; + case 'A': + case 'a': + found=1; + skip(s); + if(*s>='0' && *s<='9') + { s=gt_num(s,&w); + if(w==0) break; + (void) op_gen(AW,w,0,0); + break; + } + (void) op_gen(A,0,0,0); + break; + case 'F': + case 'f': + found=1; + s=gt_num(s,&w); + if(w==0) break; + if(*s=='.') + { s++; + s=gt_num(s,&d); + } + else d=0; + (void) op_gen(F,w,d,0); + break; + case 'D': + case 'd': + found=1; + s=gt_num(s,&w); + if(w==0) break; + if(*s=='.') + { s++; + s=gt_num(s,&d); + } + else d=0; + (void) op_gen(D,w,d,0); + break; + case 'I': + case 'i': + found=1; + s=gt_num(s,&w); + if(w==0) break; + if(*s!='.') + { (void) op_gen(I,w,0,0); + break; + } + s++; + s=gt_num(s,&d); + (void) op_gen(IM,w,d,0); + break; + } + if(found==0) + { pc--; /*unSTACK*/ + *p=sv; + return(0); + } + *p=s; + return(1); +} +op_gen(a,b,c,d) +{ struct syl *p= &syl[pc]; + if(pc>=SYLMX) + { fprintf(stderr,"format too complicated:\n"); + sig_die(fmtbuf, 1); + } + p->op=a; + p->p1=b; + p->p2=c; + p->p3=d; + return(pc++); +} +char *gt_num(s,n) char *s; int *n; +{ int m=0,cnt=0; + char c; + for(c= *s;;c = *s) + { if(c==' ') + { s++; + continue; + } + if(c>'9' || c<'0') break; + m=10*m+c-'0'; + cnt++; + s++; + } + if(cnt==0) *n=1; + else *n=m; + return(s); +} +#define STKSZ 10 +int cnt[STKSZ],ret[STKSZ],cp,rp; +flag workdone, nonl; + +integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr; +{ struct syl *p; + int n,i; + for(i=0;i<*number;i++,ptr+=len) + { +loop: switch(type_f((p= &syl[pc])->op)) + { + default: + fprintf(stderr,"unknown code in do_fio: %d\n%s\n", + p->op,fmtbuf); + err(elist->cierr,100,"do_fio"); + case NED: + if((*doned)(p)) + { pc++; + goto loop; + } + pc++; + continue; + case ED: + if(cnt[cp]<=0) + { cp--; + pc++; + goto loop; + } + if(ptr==NULL) + return((*doend)()); + cnt[cp]--; + workdone=1; + if((n=(*doed)(p,ptr,len))>0) err(elist->cierr,errno,"fmt"); + if(n<0) err(elist->ciend,(EOF),"fmt"); + continue; + case STACK: + cnt[++cp]=p->p1; + pc++; + goto loop; + case RET: + ret[++rp]=p->p1; + pc++; + goto loop; + case GOTO: + if(--cnt[cp]<=0) + { cp--; + rp--; + pc++; + goto loop; + } + pc=1+ret[rp--]; + goto loop; + case REVERT: + rp=cp=0; + pc = p->p1; + if(ptr==NULL) + return((*doend)()); + if(!workdone) return(0); + if((n=(*dorevert)()) != 0) return(n); + goto loop; + case COLON: + if(ptr==NULL) + return((*doend)()); + pc++; + goto loop; + case NONL: + nonl = 1; + pc++; + goto loop; + case S: + case SS: + cplus=0; + pc++; + goto loop; + case SP: + cplus = 1; + pc++; + goto loop; + case P: scale=p->p1; + pc++; + goto loop; + case BN: + cblank=0; + pc++; + goto loop; + case BZ: + cblank=1; + pc++; + goto loop; + } + } + return(0); +} +en_fio() +{ ftnint one=1; + return(do_fio(&one,(char *)NULL,(ftnint)0)); +} +fmt_bg() +{ + workdone=cp=rp=pc=cursor=0; + cnt[0]=ret[0]=0; +} +type_f(n) +{ + switch(n) + { + default: + return(n); + case RET: + return(RET); + case REVERT: return(REVERT); + case GOTO: return(GOTO); + case STACK: return(STACK); + case X: + case SLASH: + case APOS: case H: + case T: case TL: case TR: + return(NED); + case F: + case I: + case IM: + case A: case AW: + case O: + case L: + case E: case EE: case D: + case G: case GE: + return(ED); + } +} +char *ap_end(s) char *s; +{ char quote; + quote= *s++; + for(;*s;s++) + { if(*s!=quote) continue; + if(*++s!=quote) return(s); + } + if(elist->cierr) { + errno = 100; + return(NULL); + } + fatal(100, "bad string"); + /*NOTREACHED*/ return 0; +} diff --git a/lang/fortran/lib/libI77/fmt.h b/lang/fortran/lib/libI77/fmt.h new file mode 100644 index 000000000..bc0371142 --- /dev/null +++ b/lang/fortran/lib/libI77/fmt.h @@ -0,0 +1,57 @@ +struct syl +{ int op,p1,p2,p3; +}; +#define RET 1 +#define REVERT 2 +#define GOTO 3 +#define X 4 +#define SLASH 5 +#define STACK 6 +#define I 7 +#define ED 8 +#define NED 9 +#define IM 10 +#define APOS 11 +#define H 12 +#define TL 13 +#define TR 14 +#define T 15 +#define COLON 16 +#define S 17 +#define SP 18 +#define SS 19 +#define P 20 +#define BN 21 +#define BZ 22 +#define F 23 +#define E 24 +#define EE 25 +#define D 26 +#define G 27 +#define GE 28 +#define L 29 +#define A 30 +#define AW 31 +#define O 32 +#define NONL 33 +extern struct syl syl[]; +extern int pc,parenlvl,revloc; +extern int (*doed)(),(*doned)(); +extern int (*dorevert)(),(*donewrec)(),(*doend)(); +extern flag cblank,cplus,workdone, nonl; +extern int dummy(); +extern char *fmtbuf; +extern int scale; +typedef union +{ real pf; + doublereal pd; +} ufloat; +typedef union +{ short is; + char ic; + long il; +} uint; +#define GET(x) if((x=(*getn)())<0) return(x) +#define VAL(x) (x!='\n'?x:' ') +#define PUT(x) (*putn)(x) +extern int cursor; diff --git a/lang/fortran/lib/libI77/fmtlib.c b/lang/fortran/lib/libI77/fmtlib.c new file mode 100644 index 000000000..9fbff5b68 --- /dev/null +++ b/lang/fortran/lib/libI77/fmtlib.c @@ -0,0 +1,24 @@ +/* @(#)fmtlib.c 1.2 */ +#define MAXINTLENGTH 23 +char *icvt(value,ndigit,sign, base) long value; int *ndigit,*sign; +register int base; +{ static char buf[MAXINTLENGTH+1]; + register int i; + if(value>0) *sign=0; + else if(value<0) + { value = -value; + *sign= 1; + } + else + { *sign=0; + *ndigit=1; + buf[MAXINTLENGTH]='0'; + return(&buf[MAXINTLENGTH]); + } + for(i=MAXINTLENGTH-1;value>0;i--) + { *(buf+i)=(int)(value%base)+'0'; + value /= base; + } + *ndigit=MAXINTLENGTH-1-i; + return(&buf[i+1]); +} diff --git a/lang/fortran/lib/libI77/fp.h b/lang/fortran/lib/libI77/fp.h new file mode 100644 index 000000000..033cb03f2 --- /dev/null +++ b/lang/fortran/lib/libI77/fp.h @@ -0,0 +1,26 @@ +#define FMAX 40 +#define EXPMAXDIGS 8 +#define EXPMAX 99999999 +/* FMAX = max number of nonzero digits passed to atof() */ +/* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */ + +#include "local.h" + +/* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily + tight) on the maximum number of digits to the right and left of + * the decimal point. + */ + +#ifdef VAX +#define MAXFRACDIGS 56 +#define MAXINTDIGS 38 +#else +#ifdef CRAY +#define MAXFRACDIGS 9880 +#define MAXINTDIGS 9864 +#else +/* values that suffice for IEEE double */ +#define MAXFRACDIGS 344 +#define MAXINTDIGS 308 +#endif +#endif diff --git a/lang/fortran/lib/libI77/iio.c b/lang/fortran/lib/libI77/iio.c new file mode 100644 index 000000000..6cab0da53 --- /dev/null +++ b/lang/fortran/lib/libI77/iio.c @@ -0,0 +1,116 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +extern char *icptr; +char *icend; +extern icilist *svic; +extern int rd_ed(),rd_ned(),w_ed(),w_ned(),y_ierr(); +extern int z_wnew(); +int icnum; +extern int hiwater; +z_getc() +{ + if(icptr >= icend) err(svic->iciend,(EOF),"endfile"); + if(recpos++ < svic->icirlen) + return(*icptr++); + else err(svic->icierr,110,"recend"); +} +z_putc(c) +{ + if(icptr >= icend) err(svic->icierr,110,"inwrite"); + if(recpos++ < svic->icirlen) + *icptr++ = c; + else err(svic->icierr,110,"recend"); + return 0; +} +z_rnew() +{ + icptr = svic->iciunit + (++icnum)*svic->icirlen; + recpos = 0; + cursor = 0; + hiwater = 0; + return 1; +} + + static int +z_endp(a) icilist *a; +{ + (*donewrec)(); + return 0; + } + +integer s_rsfi(a) icilist *a; +{ int n; + if(n=c_si(a)) return(n); + reading=1; + doed=rd_ed; + doned=rd_ned; + getn=z_getc; + dorevert = y_ierr; + donewrec = z_rnew; + doend = z_endp; + return(0); +} + +integer s_wsfi(a) icilist *a; +{ int n; + if(n=c_si(a)) return(n); + reading=0; + doed=w_ed; + doned=w_ned; + putn=z_putc; + dorevert = y_ierr; + donewrec = z_wnew; + doend = z_endp; + return(0); +} +c_si(a) icilist *a; +{ + elist = (cilist *)a; + fmtbuf=a->icifmt; + if(pars_f(fmtbuf)<0) + err(a->icierr,100,"startint"); + fmt_bg(); + sequential=formatted=1; + external=0; + cblank=cplus=scale=0; + svic=a; + icnum=recpos=0; + cursor = 0; + hiwater = 0; + icptr = a->iciunit; + icend = icptr + a->icirlen*a->icirnum; + curunit = 0; + return(0); +} +z_wnew() +{ + while(recpos++ < svic->icirlen) + *icptr++ = ' '; + recpos = 0; + cursor = 0; + hiwater = 0; + icnum++; + return 1; +} +integer e_rsfi() +{ int n; + n = en_fio(); + fmtbuf = NULL; + return(n); +} +integer e_wsfi() +{ + int n; + n = en_fio(); + fmtbuf = NULL; + if(icnum >= svic->icirnum) + return(n); + while(recpos++ < svic->icirlen) + *icptr++ = ' '; + return(n); +} +y_ierr() +{ + err(elist->cierr, 110, "iio"); +} diff --git a/lang/fortran/lib/libI77/ilnw.c b/lang/fortran/lib/libI77/ilnw.c new file mode 100644 index 000000000..a4a99764f --- /dev/null +++ b/lang/fortran/lib/libI77/ilnw.c @@ -0,0 +1,62 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +extern char *icptr; +extern char *icend; +extern icilist *svic; +extern int icnum; +extern int (*donewrec)(); +extern int z_putc(), l_write(); + + static int +z_wSL() +{ + extern int z_rnew(); + while(recpos < svic->icirlen) + z_putc(' '); + return z_rnew(); + } + + int +c_liw(a) + icilist *a; +{ + reading = 0; + external = 0; + formatted = 1; + putn = z_putc; + L_len = a->icirlen; + donewrec = z_wSL; + svic = a; + icnum = recpos = 0; + cursor = 0; + cf = 0; + curunit = 0; + icptr = a->iciunit; + icend = icptr + a->icirlen*a->icirnum; + } + +s_wsni(a) + icilist *a; +{ + cilist ca; + + c_liw(a); + ca.cifmt = a->icifmt; + x_wsne(&ca); + z_wSL(); + return 0; + } + +integer s_wsli(a) icilist *a; +{ + lioproc = l_write; + c_liw(a); + return(0); + } + +integer e_wsli() +{ + z_wSL(); + return(0); + } diff --git a/lang/fortran/lib/libI77/inquire.c b/lang/fortran/lib/libI77/inquire.c new file mode 100644 index 000000000..425e64ed0 --- /dev/null +++ b/lang/fortran/lib/libI77/inquire.c @@ -0,0 +1,93 @@ +#include "f2c.h" +#include "fio.h" +integer f_inqu(a) inlist *a; +{ flag byfile; + int i, n; + unit *p; + char buf[256]; + long x; + if(a->infile!=NULL) + { byfile=1; + g_char(a->infile,a->infilen,buf); +#ifdef MSDOS + x = access(buf,0) ? -1 : 0; + for(i=0,p=NULL;iinunitinunit>=0) + { + p= &units[a->inunit]; + } + else + { + p=NULL; + } + } + if(a->inex!=NULL) + if(byfile && x != -1 || !byfile && p!=NULL) + *a->inex=1; + else *a->inex=0; + if(a->inopen!=NULL) + if(byfile) *a->inopen=(p!=NULL); + else *a->inopen=(p!=NULL && p->ufd!=NULL); + if(a->innum!=NULL) *a->innum= p-units; + if(a->innamed!=NULL) + if(byfile || p!=NULL && p->ufnm!=NULL) + *a->innamed=1; + else *a->innamed=0; + if(a->inname!=NULL) + if(byfile) + b_char(buf,a->inname,a->innamlen); + else if(p!=NULL && p->ufnm!=NULL) + b_char(p->ufnm,a->inname,a->innamlen); + if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL) + if(p->url) + b_char("DIRECT",a->inacc,a->inacclen); + else b_char("SEQUENTIAL",a->inacc,a->inacclen); + if(a->inseq!=NULL) + if(p!=NULL && p->url) + b_char("NO",a->inseq,a->inseqlen); + else b_char("YES",a->inseq,a->inseqlen); + if(a->indir!=NULL) + if(p==NULL || p->url) + b_char("YES",a->indir,a->indirlen); + else b_char("NO",a->indir,a->indirlen); + if(a->infmt!=NULL) + if(p!=NULL && p->ufmt==0) + b_char("UNFORMATTED",a->infmt,a->infmtlen); + else b_char("FORMATTED",a->infmt,a->infmtlen); + if(a->inform!=NULL) + if(p!=NULL && p->ufmt==0) + b_char("NO",a->inform,a->informlen); + else b_char("YES",a->inform,a->informlen); + if(a->inunf) + if(p!=NULL && p->ufmt==0) + b_char("YES",a->inunf,a->inunflen); + else if (p!=NULL) b_char("NO",a->inunf,a->inunflen); + else b_char("UNKNOWN",a->inunf,a->inunflen); + if(a->inrecl!=NULL && p!=NULL) + *a->inrecl=p->url; + if(a->innrec!=NULL && p!=NULL && p->url>0) + *a->innrec=ftell(p->ufd)/p->url+1; + if(a->inblank && p!=NULL && p->ufmt) + if(p->ublnk) + b_char("ZERO",a->inblank,a->inblanklen); + else b_char("NULL",a->inblank,a->inblanklen); + return(0); +} diff --git a/lang/fortran/lib/libI77/libI77.xsum b/lang/fortran/lib/libI77/libI77.xsum new file mode 100644 index 000000000..9216febc0 --- /dev/null +++ b/lang/fortran/lib/libI77/libI77.xsum @@ -0,0 +1,39 @@ +Notice fb5a412e 1183 +README 11f3b057 3861 +Version.c f5466c95 3906 +backspace.c 1fb89c72 1252 +close.c f5b0a34 903 +dfe.c f79d0dc0 2463 +dolio.c 182d4c60 171 +due.c e969b824 1157 +endfile.c ef355044 1565 +err.c bbc2455 5270 +fio.h ff0cdf36 1289 +fmt.c f10c2693 6872 +fmt.h 464603c 960 +fmtlib.c 19f5bfc7 487 +fp.h 8d2c32e 613 +iio.c f93e1289 1827 +ilnw.c a849740 799 +inquire.c 86dbf5e 2313 +lio.h f14b794d 763 +lread.c fb8ef2ac 9054 +lwrite.c f133d18b 2392 +makefile f98cddc3 1819 +open.c a131d7e 3573 +rdfmt.c f6daa35f 5703 +rewind.c f9aac3ab 350 +rsfe.c fcfa2e1f 1175 +rsli.c fb196d1 1249 +rsne.c 12ba3382 8392 +sfe.c ef16283a 555 +sue.c 8ba8875 1420 +typesize.c f31c8492 197 +uio.c f12544cd 906 +util.c ebe8973 1036 +wref.c 65fbc97 3632 +wrtfmt.c e77eafc 5358 +wsfe.c cbef67 1540 +wsle.c 8622874 552 +wsne.c 1d6ff5 435 +xwsne.c fab6cba6 882 diff --git a/lang/fortran/lib/libI77/lio.h b/lang/fortran/lib/libI77/lio.h new file mode 100644 index 000000000..e78b7ff6e --- /dev/null +++ b/lang/fortran/lib/libI77/lio.h @@ -0,0 +1,41 @@ +/* copy of ftypes from the compiler */ +/* variable types + * numeric assumptions: + * int < reals < complexes + * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX + */ + +#define TYUNKNOWN 0 +#define TYADDR 1 +#define TYSHORT 2 +#define TYLONG 3 +#define TYREAL 4 +#define TYDREAL 5 +#define TYCOMPLEX 6 +#define TYDCOMPLEX 7 +#define TYLOGICAL 8 +#define TYCHAR 9 +#define TYSUBR 10 +#define TYERROR 11 + +#define NTYPES (TYERROR+1) + +#define LINTW 12 +#define LINE 80 +#define LLOGW 2 +#define LLOW 1.0 +#define LHIGH 1.e9 +#define LEFMT " %# .8E" +#define LFFMT " %# .9g" +/* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */ +#define LEFBL 24 + +typedef union +{ short flshort; + ftnint flint; + real flreal; + doublereal fldouble; +} flex; +extern int scale; +extern int (*lioproc)(); +extern int L_len; diff --git a/lang/fortran/lib/libI77/local.h b/lang/fortran/lib/libI77/local.h new file mode 100644 index 000000000..e69de29bb diff --git a/lang/fortran/lib/libI77/lread.c b/lang/fortran/lib/libI77/lread.c new file mode 100644 index 000000000..4f92cde2d --- /dev/null +++ b/lang/fortran/lib/libI77/lread.c @@ -0,0 +1,526 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#include "lio.h" +#include "ctype.h" +#include "fp.h" + +extern char *fmtbuf; +extern char *malloc(), *realloc(); +int (*lioproc)(), (*l_getc)(), (*l_ungetc)(); +int l_eof; + +#define isblnk(x) (ltab[x+1]&B) +#define issep(x) (ltab[x+1]&SX) +#define isapos(x) (ltab[x+1]&AX) +#define isexp(x) (ltab[x+1]&EX) +#define issign(x) (ltab[x+1]&SG) +#define iswhit(x) (ltab[x+1]&WH) +#define SX 1 +#define B 2 +#define AX 4 +#define EX 8 +#define SG 16 +#define WH 32 +char ltab[128+1] = { /* offset one for EOF */ + 0, + 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 +}; + +t_getc() +{ int ch; + if(curunit->uend) return(EOF); + if((ch=getc(cf))!=EOF) return(ch); + if(feof(cf)) + l_eof = curunit->uend = 1; + return(EOF); +} +integer e_rsle() +{ + int ch; + if(curunit->uend) return(0); + while((ch=t_getc())!='\n' && ch!=EOF); + return(0); +} + +flag lquit; +int lcount,ltype; +char *lchar; +double lx,ly; +#define ERR(x) if(n=(x)) return(n) +#define GETC(x) (x=(*l_getc)()) +#define Ungetc(x,y) (*l_ungetc)(x,y) + +l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; +{ +#define Ptr ((flex *)ptr) + int i,n,ch; + doublereal *yy; + real *xx; + for(i=0;i<*number;i++) + { + if(lquit) return(0); + if(l_eof) + err(elist->ciend, EOF, "list in") + if(lcount == 0) { + ltype = 0; + for(;;) { + GETC(ch); + switch(ch) { + case EOF: + goto loopend; + case ' ': + case '\t': + case '\n': + continue; + case '/': + lquit = 1; + goto loopend; + case ',': + lcount = 1; + goto loopend; + default: + (void) Ungetc(ch, cf); + goto rddata; + } + } + } + rddata: + switch((int)type) + { + case TYSHORT: + case TYLONG: + case TYREAL: + case TYDREAL: + ERR(l_R(0)); + break; + case TYCOMPLEX: + case TYDCOMPLEX: + ERR(l_C()); + break; + case TYLOGICAL: + ERR(l_L()); + break; + case TYCHAR: + ERR(l_CHAR()); + break; + } + while (GETC(ch) == ' ' || ch == '\t'); + if (ch != ',') + Ungetc(ch,cf); + loopend: + if(lquit) return(0); + if(cf) { + if (feof(cf)) + err(elist->ciend,(EOF),"list in") + else if(ferror(cf)) { + clearerr(cf); + err(elist->cierr,errno,"list in") + } + } + if(ltype==0) goto bump; + switch((int)type) + { + case TYSHORT: + Ptr->flshort=lx; + break; + case TYLOGICAL: + case TYLONG: + Ptr->flint=lx; + break; + case TYREAL: + Ptr->flreal=lx; + break; + case TYDREAL: + Ptr->fldouble=lx; + break; + case TYCOMPLEX: + xx=(real *)ptr; + *xx++ = lx; + *xx = ly; + break; + case TYDCOMPLEX: + yy=(doublereal *)ptr; + *yy++ = lx; + *yy = ly; + break; + case TYCHAR: + b_char(lchar,ptr,len); + break; + } + bump: + if(lcount>0) lcount--; + ptr += len; + } + return(0); +#undef Ptr +} +l_R(poststar) + int poststar; +{ + char s[FMAX+EXPMAXDIGS+4]; + register int ch; + register char *sp, *spe, *sp1; + long e, exp; + double atof(); + int havenum, se; + + if (!poststar) { + if (lcount > 0) + return(0); + lcount = 1; + } + ltype = 0; + exp = 0; +retry: + sp1 = sp = s; + spe = sp + FMAX; + havenum = 0; + + switch(GETC(ch)) { + case '-': *sp++ = ch; sp1++; spe++; + case '+': + GETC(ch); + } + while(ch == '0') { + ++havenum; + GETC(ch); + } + while(isdigit(ch)) { + if (sp < spe) *sp++ = ch; + else ++exp; + GETC(ch); + } + if (ch == '*' && !poststar) { + if (sp == sp1 || exp || *s == '-') { + err(elist->cierr,112,"bad repetition count") + } + poststar = 1; + *sp = 0; + lcount = atoi(s); + goto retry; + } + if (ch == '.') { + GETC(ch); + if (sp == sp1) + while(ch == '0') { + ++havenum; + --exp; + GETC(ch); + } + while(isdigit(ch)) { + if (sp < spe) + { *sp++ = ch; --exp; } + GETC(ch); + } + } + se = 0; + if (issign(ch)) + goto signonly; + if (isexp(ch)) { + GETC(ch); + if (issign(ch)) { +signonly: + if (ch == '-') se = 1; + GETC(ch); + } + if (!isdigit(ch)) { +bad: + err(elist->cierr,112,"exponent field") + } + + e = ch - '0'; + while(isdigit(GETC(ch))) { + e = 10*e + ch - '0'; + if (e > EXPMAX) + goto bad; + } + if (se) + exp -= e; + else + exp += e; + } + (void) Ungetc(ch, cf); + if (sp > sp1) { + ++havenum; + while(*--sp == '0') + ++exp; + if (exp) + sprintf(sp+1, "e%ld", exp); + else + sp[1] = 0; + lx = atof(s); + } + else + lx = 0.; + if (havenum) + ltype = TYLONG; + else + switch(ch) { + case ',': + case '/': + break; + default: + err(elist->cierr,112,"invalid number") + } + return 0; + } + + static int +rd_count(ch) + register int ch; +{ + if (ch < '0' || ch > '9') + return 1; + lcount = ch - '0'; + while(GETC(ch) >= '0' && ch <= '9') + lcount = 10*lcount + ch - '0'; + Ungetc(ch,cf); + return 0; + } + +l_C() +{ int ch; + double lz; + if(lcount>0) return(0); + ltype=0; + GETC(ch); + if(ch!='(') + { + if (rd_count(ch)) + if(!cf || !feof(cf)) + err(elist->cierr,112,"complex format") + else + err(elist->cierr,(EOF),"lread"); + if(GETC(ch)!='*') + { + if(!cf || !feof(cf)) + err(elist->cierr,112,"no star") + else + err(elist->cierr,(EOF),"lread"); + } + if(GETC(ch)!='(') + { (void) Ungetc(ch,cf); + return(0); + } + } + else + lcount = 1; + while(iswhit(GETC(ch))); + (void) Ungetc(ch,cf); + if (ch = l_R(1)) + return ch; + if (!ltype) + err(elist->cierr,112,"no real part"); + lz = lx; + while(iswhit(GETC(ch))); + if(ch!=',') + { (void) Ungetc(ch,cf); + err(elist->cierr,112,"no comma"); + } + while(iswhit(GETC(ch))); + (void) Ungetc(ch,cf); + if (ch = l_R(1)) + return ch; + if (!ltype) + err(elist->cierr,112,"no imaginary part"); + while(iswhit(GETC(ch))); + if(ch!=')') err(elist->cierr,112,"no )"); + ly = lx; + lx = lz; + return(0); +} +l_L() +{ + int ch; + if(lcount>0) return(0); + ltype=0; + GETC(ch); + if(isdigit(ch)) + { + rd_count(ch); + if(GETC(ch)!='*') + if(!cf || !feof(cf)) + err(elist->cierr,112,"no star") + else + err(elist->cierr,(EOF),"lread"); + GETC(ch); + } + if(ch == '.') GETC(ch); + switch(ch) + { + case 't': + case 'T': + lx=1; + break; + case 'f': + case 'F': + lx=0; + break; + default: + if(isblnk(ch) || issep(ch) || ch==EOF) + { (void) Ungetc(ch,cf); + return(0); + } + else err(elist->cierr,112,"logical"); + } + ltype=TYLONG; + lcount = 1; + while(!issep(GETC(ch)) && ch!=EOF); + (void) Ungetc(ch, cf); + return(0); +} +#define BUFSIZE 128 +l_CHAR() +{ int ch,size,i; + char quote,*p; + if(lcount>0) return(0); + ltype=0; + if(lchar!=NULL) free(lchar); + size=BUFSIZE; + p=lchar=malloc((unsigned int)size); + if(lchar==NULL) err(elist->cierr,113,"no space"); + + GETC(ch); + if(isdigit(ch)) { + /* allow Fortran 8x-style unquoted string... */ + /* either find a repetition count or the string */ + lcount = ch - '0'; + *p++ = ch; + for(i = 1;;) { + switch(GETC(ch)) { + case '*': + if (lcount == 0) { + lcount = 1; + goto noquote; + } + p = lchar; + goto have_lcount; + case ',': + case ' ': + case '\t': + case '\n': + case '/': + Ungetc(ch,cf); + /* no break */ + case EOF: + lcount = 1; + ltype = TYCHAR; + return *p = 0; + } + if (!isdigit(ch)) { + lcount = 1; + goto noquote; + } + *p++ = ch; + lcount = 10*lcount + ch - '0'; + if (++i == size) { + lchar = realloc(lchar, + (unsigned int)(size += BUFSIZE)); + p = lchar + i; + } + } + } + else (void) Ungetc(ch,cf); + have_lcount: + if(GETC(ch)=='\'' || ch=='"') quote=ch; + else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) + { (void) Ungetc(ch,cf); + return(0); + } + else { + /* Fortran 8x-style unquoted string */ + *p++ = ch; + for(i = 1;;) { + switch(GETC(ch)) { + case ',': + case ' ': + case '\t': + case '\n': + case '/': + Ungetc(ch,cf); + /* no break */ + case EOF: + ltype = TYCHAR; + return *p = 0; + } + noquote: + *p++ = ch; + if (++i == size) { + lchar = realloc(lchar, + (unsigned int)(size += BUFSIZE)); + p = lchar + i; + } + } + } + ltype=TYCHAR; + for(i=0;;) + { while(GETC(ch)!=quote && ch!='\n' + && ch!=EOF && ++iuwrt && nowreading(curunit)) + err(a->cierr,errno,"read start"); + l_getc = t_getc; + l_ungetc = ungetc; + return(0); +} +c_le(a) cilist *a; +{ + fmtbuf="list io"; + if(a->ciunit>=MXUNIT || a->ciunit<0) + err(a->cierr,101,"stler"); + scale=recpos=0; + elist=a; + curunit = &units[a->ciunit]; + if(curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) + err(a->cierr,102,"lio"); + cf=curunit->ufd; + if(!curunit->ufmt) err(a->cierr,103,"lio") + return(0); +} diff --git a/lang/fortran/lib/libI77/lwrite.c b/lang/fortran/lib/libI77/lwrite.c new file mode 100644 index 000000000..ee931e15e --- /dev/null +++ b/lang/fortran/lib/libI77/lwrite.c @@ -0,0 +1,148 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#include "lio.h" +int L_len; + +t_putc(c) +{ + recpos++; + putc(c,cf); + return(0); +} +lwrt_I(n) ftnint n; +{ + char buf[LINTW],*p; +#ifdef USE_STRLEN + (void) sprintf(buf," %ld",(long)n); + if(recpos+strlen(buf)>=L_len) +#else + if(recpos + sprintf(buf," %ld",(long)n) >= L_len) +#endif + (*donewrec)(); + for(p=buf;*p;PUT(*p++)); +} +lwrt_L(n, len) ftnint n; ftnlen len; +{ + if(recpos+LLOGW>=L_len) + (*donewrec)(); + (void) wrt_L((uint *)&n,LLOGW, len); +} +lwrt_A(p,len) char *p; ftnlen len; +{ + int i; + if(recpos+len>=L_len) + (*donewrec)(); + if (!recpos) + { PUT(' '); ++recpos; } + for(i=0;i= L_len) + (*donewrec)(); + l_put(buf); +} +lwrt_C(a,b) double a,b; +{ + char *ba, *bb, bufa[LEFBL], bufb[LEFBL]; + int al, bl; + + al = l_g(bufa, a); + for(ba = bufa; *ba == ' '; ba++) + --al; + bl = l_g(bufb, b) + 1; /* intentionally high by 1 */ + for(bb = bufb; *bb == ' '; bb++) + --bl; + if(recpos + al + bl + 3 >= L_len && recpos) + (*donewrec)(); + PUT(' '); + PUT('('); + l_put(ba); + PUT(','); + if (recpos + bl >= L_len) { + (*donewrec)(); + PUT(' '); + } + l_put(bb); + PUT(')'); +} +l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; +{ +#define Ptr ((flex *)ptr) + int i; + ftnint x; + double y,z; + real *xx; + doublereal *yy; + for(i=0;i< *number; i++) + { + switch((int)type) + { + default: fatal(204,"unknown type in lio"); + case TYSHORT: + x=Ptr->flshort; + goto xint; + case TYLONG: + x=Ptr->flint; + xint: lwrt_I(x); + break; + case TYREAL: + y=Ptr->flreal; + goto xfloat; + case TYDREAL: + y=Ptr->fldouble; + xfloat: lwrt_F(y); + break; + case TYCOMPLEX: + xx= &Ptr->flreal; + y = *xx++; + z = *xx; + goto xcomplex; + case TYDCOMPLEX: + yy = &Ptr->fldouble; + y= *yy++; + z = *yy; + xcomplex: + lwrt_C(y,z); + break; + case TYLOGICAL: + lwrt_L(Ptr->flint, len); + break; + case TYCHAR: + lwrt_A(ptr,len); + break; + } + ptr += len; + } + return(0); +} diff --git a/lang/fortran/lib/libI77/makefile b/lang/fortran/lib/libI77/makefile new file mode 100644 index 000000000..04e771544 --- /dev/null +++ b/lang/fortran/lib/libI77/makefile @@ -0,0 +1,92 @@ +.SUFFIXES: .c .o + +CC = cc +CFLAGS = -DSkip_f2c_Undefs -O +SHELL = /bin/sh + +# compile, then strip unnecessary symbols +.c.o: + $(CC) $(CFLAGS) -c $*.c + ld -r -x $*.o + mv a.out $*.o + +OBJ = Version.o backspace.o close.o dfe.o dolio.o due.o endfile.o err.o \ + fmt.o fmtlib.o iio.o ilnw.o inquire.o lread.o lwrite.o open.o \ + rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o typesize.o uio.o \ + util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o +libI77.a: $(OBJ) + ar r libI77.a $? + ranlib libI77.a +install: libI77.a + cp libI77.a /usr/lib/libI77.a + ranlib /usr/lib/libI77.a + +Version.o: Version.c + $(CC) -c Version.c + + +clean: + rm -f $(OBJ) libI77.a + +clobber: clean + rm -f libI77.a + +backspace.o: fio.h +close.o: fio.h +dfe.o: fio.h +dfe.o: fmt.h +due.o: fio.h +endfile.o: fio.h +err.o: fio.h +fmt.o: fio.h +fmt.o: fmt.h +iio.o: fio.h +iio.o: fmt.h +ilnw.o: fio.h +ilnw.o: lio.h +inquire.o: fio.h +lread.o: fio.h +lread.o: fmt.h +lread.o: lio.h +lread.o: fp.h +lwrite.o: fio.h +lwrite.o: fmt.h +lwrite.o: lio.h +open.o: fio.h +rdfmt.o: fio.h +rdfmt.o: fmt.h +rdfmt.o: fp.h +rewind.o: fio.h +rsfe.o: fio.h +rsfe.o: fmt.h +rsli.o: fio.h +rsli.o: lio.h +rsne.o: fio.h +rsne.o: lio.h +sfe.o: fio.h +sue.o: fio.h +uio.o: fio.h +util.o: fio.h +wref.o: fio.h +wref.o: fmt.h +wref.o: fp.h +wrtfmt.o: fio.h +wrtfmt.o: fmt.h +wsfe.o: fio.h +wsfe.o: fmt.h +wsle.o: fio.h +wsle.o: fmt.h +wsle.o: lio.h +wsne.o: fio.h +wsne.o: lio.h +xwsne.o: fio.h +xwsne.o: lio.h +xwsne.o: fmt.h + +check: + xsum Notice README Version.c backspace.c close.c dfe.c dolio.c \ + due.c endfile.c err.c fio.h fmt.c fmt.h fmtlib.c fp.h iio.c \ + ilnw.c inquire.c lio.h lread.c lwrite.c makefile open.c \ + rdfmt.c rewind.c rsfe.c rsli.c rsne.c sfe.c sue.c typesize.c \ + uio.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c xwsne.c >zap + cmp zap libI77.xsum && rm zap || diff libI77.xsum zap diff --git a/lang/fortran/lib/libI77/open.c b/lang/fortran/lib/libI77/open.c new file mode 100644 index 000000000..516c69082 --- /dev/null +++ b/lang/fortran/lib/libI77/open.c @@ -0,0 +1,190 @@ +#include "sys/types.h" +#ifndef MSDOS +#include "sys/stat.h" +#endif +#include "f2c.h" +#include "fio.h" +#include "string.h" +#include "fcntl.h" +#ifndef O_WRONLY +#define O_RDONLY 0 +#define O_WRONLY 1 +#endif + +extern char *malloc(), *mktemp(); +extern FILE *fdopen(); +extern integer f_clos(); +#ifdef NON_ANSI_RW_MODES +char *r_mode[2] = {"r", "r"}; +char *w_mode[2] = {"w", "w"}; +#else +char *r_mode[2] = {"rb", "r"}; +char *w_mode[2] = {"wb", "w"}; +#endif + +integer f_open(a) olist *a; +{ unit *b; + int n; + char buf[256]; + cllist x; +#ifndef MSDOS + struct stat stb; +#endif + if(a->ounit>=MXUNIT || a->ounit<0) + err(a->oerr,101,"open") + curunit = b = &units[a->ounit]; + if(b->ufd) { + if(a->ofnm==0) + { + same: if (a->oblnk) + b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z'; + return(0); + } +#ifdef MSDOS + if (b->ufnm + && strlen(b->ufnm) == a->ofnmlen + && !strncmp(b->ufnm, b->ufnm, (unsigned)a->ofnmlen)) + goto same; +#else + g_char(a->ofnm,a->ofnmlen,buf); + if (inode(buf,&n) == b->uinode && n == b->udev) + goto same; +#endif + x.cunit=a->ounit; + x.csta=0; + x.cerr=a->oerr; + if((n=f_clos(&x))!=0) return(n); + } + b->url=a->orl; + b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z'); + if(a->ofm==0) + { if(b->url>0) b->ufmt=0; + else b->ufmt=1; + } + else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1; + else b->ufmt=0; +#ifdef url_Adjust + if (b->url && !b->ufmt) + url_Adjust(b->url); +#endif + if (a->ofnm) { + g_char(a->ofnm,a->ofnmlen,buf); + if (!buf[0]) + err(a->oerr,107,"open") + } + else + sprintf(buf, "fort.%ld", a->ounit); + b->uscrtch = 0; + switch(a->osta ? *a->osta : 'u') + { + case 'o': + case 'O': +#ifdef MSDOS + if(access(buf,0)) +#else + if(stat(buf,&stb)) +#endif + err(a->oerr,errno,"open") + break; + case 's': + case 'S': + b->uscrtch=1; + (void) strcpy(buf,"tmp.FXXXXXX"); + (void) mktemp(buf); + (void) close(creat(buf, 0666)); + break; + case 'n': + case 'N': +#ifdef MSDOS + if(!access(buf,0)) +#else + if(!stat(buf,&stb)) +#endif + err(a->oerr,128,"open") + /* no break */ + case 'r': /* Fortran 90 replace option */ + case 'R': + (void) close(creat(buf, 0666)); + break; + } + + b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1)); + if(b->ufnm==NULL) err(a->oerr,113,"no space"); + (void) strcpy(b->ufnm,buf); + b->uend=0; + b->uwrt = 0; + if(isdev(buf)) + { b->ufd = fopen(buf,r_mode[b->ufmt]); + if(b->ufd==NULL) err(a->oerr,errno,buf) + } + else { + if((b->ufd = fopen(buf, r_mode[b->ufmt])) == NULL) { + if ((n = open(buf,O_WRONLY)) >= 0) { + b->uwrt = 2; + } + else { + n = creat(buf, 0666); + b->uwrt = 1; + } + if (n < 0 + || (b->ufd = fdopen(n, w_mode[b->ufmt])) == NULL) + err(a->oerr, errno, "open"); + } + } + b->useek=canseek(b->ufd); +#ifndef MSDOS + if((b->uinode=inode(buf,&b->udev))==-1) + err(a->oerr,108,"open") +#endif + if(a->orl && b->useek) rewind(b->ufd); + return(0); +} +fk_open(seq,fmt,n) ftnint n; +{ char nbuf[10]; + olist a; + (void) sprintf(nbuf,"fort.%ld",n); + a.oerr=1; + a.ounit=n; + a.ofnm=nbuf; + a.ofnmlen=strlen(nbuf); + a.osta=NULL; + a.oacc= seq==SEQ?"s":"d"; + a.ofm = fmt==FMT?"f":"u"; + a.orl = seq==DIR?1:0; + a.oblnk=NULL; + return(f_open(&a)); +} +isdev(s) char *s; +{ +#ifdef MSDOS + int i, j; + + i = open(s,O_RDONLY); + if (i == -1) + return 0; + j = isatty(i); + close(i); + return j; +#else + struct stat x; + + if(stat(s, &x) == -1) return(0); +#ifdef S_IFMT + switch(x.st_mode&S_IFMT) { + case S_IFREG: + case S_IFDIR: + return(0); + } +#else +#ifdef S_ISREG + /* POSIX version */ + if(S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) + return(0); + else +#else + Help! How does stat work on this system? +#endif +#endif + return(1); +#endif +} diff --git a/lang/fortran/lib/libI77/rdfmt.c b/lang/fortran/lib/libI77/rdfmt.c new file mode 100644 index 000000000..d8070ab60 --- /dev/null +++ b/lang/fortran/lib/libI77/rdfmt.c @@ -0,0 +1,324 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#include "fp.h" + +extern int cursor; +rd_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len; +{ int ch; + for(;cursor>0;cursor--) if((ch=(*getn)())<0) return(ch); + if(cursor<0) + { if(recpos+cursor < 0) /*err(elist->cierr,110,"fmt")*/ + cursor = -recpos; /* is this in the standard? */ + if(external == 0) { + extern char *icptr; + icptr += cursor; + } + else if(curunit && curunit->useek) + (void) fseek(cf,(long) cursor,SEEK_CUR); + else + err(elist->cierr,106,"fmt"); + recpos += cursor; + cursor=0; + } + switch(p->op) + { + default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op); + sig_die(fmtbuf, 1); + case I: ch = (rd_I((uint *)ptr,p->p1,len, 10)); + break; + case IM: ch = (rd_I((uint *)ptr,p->p1,len, 10)); + break; + case O: ch = (rd_I((uint *)ptr, p->p1, len, 8)); + break; + case L: ch = (rd_L((ftnint *)ptr,p->p1)); + break; + case A: ch = (rd_A(ptr,len)); + break; + case AW: + ch = (rd_AW(ptr,p->p1,len)); + break; + case E: case EE: + case D: + case G: + case GE: + case F: ch = (rd_F((ufloat *)ptr,p->p1,p->p2,len)); + break; + } + if(ch == 0) return(ch); + else if(ch == EOF) return(EOF); + clearerr(cf); + return(errno); +} +rd_ned(p) struct syl *p; +{ + switch(p->op) + { + default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op); + sig_die(fmtbuf, 1); + case APOS: + return(rd_POS(*(char **)&p->p2)); + case H: return(rd_H(p->p1,*(char **)&p->p2)); + case SLASH: return((*donewrec)()); + case TR: + case X: cursor += p->p1; + return(1); + case T: cursor=p->p1-recpos - 1; + return(1); + case TL: cursor -= p->p1; + if(cursor < -recpos) /* TL1000, 1X */ + cursor = -recpos; + return(1); + } +} +rd_I(n,w,len, base) ftnlen len; uint *n; register int base; +{ long x; + int sign,ch; + char s[84], *ps; + ps=s; x=0; + while (w) + { + GET(ch); + if (ch==',' || ch=='\n') break; + *ps=ch; ps++; w--; + } + *ps='\0'; + ps=s; + while (*ps==' ') ps++; + if (*ps=='-') { sign=1; ps++; } + else { sign=0; if (*ps=='+') ps++; } +loop: while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; } + if (*ps==' ') {if (cblank) x *= base; ps++; goto loop;} + if(sign) x = -x; + if(len==sizeof(integer)) n->il=x; + else if(len == sizeof(char)) n->ic = x; + else n->is=x; + if (*ps) return(errno=115); else return(0); +} +rd_L(n,w) ftnint *n; +{ int ch; + char s[84], *ps; + ps=s; + while (w) { + GET(ch); + if (ch==','||ch=='\n') break; + *ps=ch; + ps++; w--; + } + *ps='\0'; + ps=s; while (*ps==' ') ps++; + if (*ps=='.') ps++; + if (*ps=='t' || *ps == 'T') { *n=1; return(0); } + else if (*ps == 'f' || *ps == 'F') { *n=0; return(0); } + else return(errno=116); +} + +#include "ctype.h" + +rd_F(p, w, d, len) +ftnlen len; +ufloat *p; +{ + char s[FMAX+EXPMAXDIGS+4]; + register int ch; + register char *sp, *spe, *sp1; + double atof(), x; + int scale1, se; + long e, exp; + + sp1 = sp = s; + spe = sp + FMAX; + exp = -d; + x = 0.; + + do { + GET(ch); + w--; + } while (ch == ' ' && w); + switch(ch) { + case '-': *sp++ = ch; sp1++; spe++; + case '+': + if (!w) goto zero; + --w; + GET(ch); + } + while(ch == ' ') { +blankdrop: + if (!w--) goto zero; GET(ch); } + while(ch == '0') + { if (!w--) goto zero; GET(ch); } + if (ch == ' ' && cblank) + goto blankdrop; + scale1 = scale; + while(isdigit(ch)) { +digloop1: + if (sp < spe) *sp++ = ch; + else ++exp; +digloop1e: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (cblank) + { ch = '0'; goto digloop1; } + goto digloop1e; + } + if (ch == '.') { + exp += d; + if (!w--) goto done; + GET(ch); + if (sp == sp1) { /* no digits yet */ + while(ch == '0') { +skip01: + --exp; +skip0: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (cblank) goto skip01; + goto skip0; + } + } + while(isdigit(ch)) { +digloop2: + if (sp < spe) + { *sp++ = ch; --exp; } +digloop2e: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (cblank) + { ch = '0'; goto digloop2; } + goto digloop2e; + } + } + switch(ch) { + default: + break; + case '-': se = 1; goto signonly; + case '+': se = 0; goto signonly; + case 'e': + case 'E': + case 'd': + case 'D': + if (!w--) + goto bad; + GET(ch); + while(ch == ' ') { + if (!w--) + goto bad; + GET(ch); + } + se = 0; + switch(ch) { + case '-': se = 1; + case '+': +signonly: + if (!w--) + goto bad; + GET(ch); + } + while(ch == ' ') { + if (!w--) + goto bad; + GET(ch); + } + if (!isdigit(ch)) + goto bad; + + e = ch - '0'; + for(;;) { + if (!w--) + { ch = '\n'; break; } + GET(ch); + if (!isdigit(ch)) { + if (ch == ' ') { + if (cblank) + ch = '0'; + else continue; + } + else + break; + } + e = 10*e + ch - '0'; + if (e > EXPMAX && sp > sp1) + goto bad; + } + if (se) + exp -= e; + else + exp += e; + scale1 = 0; + } + switch(ch) { + case '\n': + case ',': + break; + default: +bad: + return (errno = 115); + } +done: + if (sp > sp1) { + while(*--sp == '0') + ++exp; + if (exp -= scale1) + sprintf(sp+1, "e%ld", exp); + else + sp[1] = 0; + x = atof(s); + } +zero: + if (len == sizeof(real)) + p->pf = x; + else + p->pd = x; + return(0); + } + + +rd_A(p,len) char *p; ftnlen len; +{ int i,ch; + for(i=0;i=len) + { for(i=0;iaunit>=MXUNIT || a->aunit<0) + err(a->aerr,101,"rewind"); + b = &units[a->aunit]; + if(b->ufd == NULL || b->uwrt == 3) + return(0); + if(!b->useek) + err(a->aerr,106,"rewind") + if(b->uwrt) { + (void) t_runc(a); + b->uwrt = 3; + } + rewind(b->ufd); + b->uend=0; + return(0); +} diff --git a/lang/fortran/lib/libI77/rsfe.c b/lang/fortran/lib/libI77/rsfe.c new file mode 100644 index 000000000..4c8b61f3c --- /dev/null +++ b/lang/fortran/lib/libI77/rsfe.c @@ -0,0 +1,70 @@ +/* read sequential formatted external */ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +extern int x_getc(),rd_ed(),rd_ned(); +extern int x_endp(),x_rev(),xrd_SL(); +integer s_rsfe(a) cilist *a; /* start */ +{ int n; + if(!init) f_init(); + if(n=c_sfe(a)) return(n); + reading=1; + sequential=1; + formatted=1; + external=1; + elist=a; + cursor=recpos=0; + scale=0; + fmtbuf=a->cifmt; + curunit= &units[a->ciunit]; + cf=curunit->ufd; + if(pars_f(fmtbuf)<0) err(a->cierr,100,"startio"); + getn= x_getc; + doed= rd_ed; + doned= rd_ned; + fmt_bg(); + doend=x_endp; + donewrec=xrd_SL; + dorevert=x_rev; + cblank=curunit->ublnk; + cplus=0; + if(curunit->uwrt && nowreading(curunit)) + err(a->cierr,errno,"read start"); + return(0); +} +xrd_SL() +{ int ch; + if(!curunit->uend) + while((ch=getc(cf))!='\n' && ch!=EOF); + cursor=recpos=0; + return(1); +} +x_getc() +{ int ch; + if(curunit->uend) return(EOF); + ch = getc(cf); + if(ch!=EOF && ch!='\n') + { recpos++; + return(ch); + } + if(ch=='\n') + { (void) ungetc(ch,cf); + return(ch); + } + if(curunit->uend || feof(cf)) + { errno=0; + curunit->uend=1; + return(-1); + } + return(-1); +} +x_endp() +{ + (void) xrd_SL(); + return(0); +} +x_rev() +{ + (void) xrd_SL(); + return(0); +} diff --git a/lang/fortran/lib/libI77/rsli.c b/lang/fortran/lib/libI77/rsli.c new file mode 100644 index 000000000..0b7732cd0 --- /dev/null +++ b/lang/fortran/lib/libI77/rsli.c @@ -0,0 +1,80 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" + +extern flag lquit; +extern int lcount; +extern int l_read(); +extern char *icptr; +extern char *icend; +extern icilist *svic; +extern int icnum, recpos; +extern int (*l_getc)(), (*l_ungetc)(); + +int i_getc() +{ + if(++recpos >= svic->icirlen) { + if (recpos == svic->icirlen) + return '\n'; + z_rnew(); + } + if(icptr >= icend) err(svic->iciend,(EOF),"endfile"); + return(*icptr++); + } + +int i_ungetc(ch) + int ch; +{ + if (--recpos == svic->icirlen) + return '\n'; + if (recpos < -1) + err(svic->icierr,110,"recend"); + /* *--icptr == ch, and icptr may point to read-only memory */ + return *--icptr /* = ch */; + } + + static void +c_lir(a) + icilist *a; +{ + extern int l_eof; + reading = 1; + external = 0; + formatted = 1; + svic = a; + L_len = a->icirlen; + recpos = -1; + icnum = recpos = 0; + cursor = 0; + l_getc = i_getc; + l_ungetc = i_ungetc; + l_eof = 0; + icptr = a->iciunit; + icend = icptr + a->icirlen*a->icirnum; + cf = 0; + curunit = 0; + } + + +integer s_rsli(a) icilist *a; +{ + lioproc = l_read; + lquit = 0; + lcount = 0; + c_lir(a); + return(0); + } + +integer e_rsli() +{ return 0; } + +s_rsni(a) + icilist *a; +{ + cilist ca; + ca.ciend = a->iciend; + ca.cierr = a->icierr; + ca.cifmt = a->icifmt; + c_lir(a); + return x_rsne(&ca); + } diff --git a/lang/fortran/lib/libI77/rsne.c b/lang/fortran/lib/libI77/rsne.c new file mode 100644 index 000000000..5a99c2384 --- /dev/null +++ b/lang/fortran/lib/libI77/rsne.c @@ -0,0 +1,444 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" + +#define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */ +#define MAXDIM 20 /* maximum number of subscripts */ + + extern char *malloc(), *memset(); + + struct dimen { + ftnlen extent; + ftnlen curval; + ftnlen delta; + ftnlen stride; + }; + typedef struct dimen dimen; + + struct hashentry { + struct hashentry *next; + char *name; + Vardesc *vd; + }; + typedef struct hashentry hashentry; + + struct hashtab { + struct hashtab *next; + Namelist *nl; + int htsize; + hashentry *tab[1]; + }; + typedef struct hashtab hashtab; + + static hashtab *nl_cache; + static n_nlcache; + static hashentry **zot; + extern ftnlen typesize[]; + + extern flag lquit; + extern int lcount; + extern int (*l_getc)(), (*l_ungetc)(), t_getc(), ungetc(); + + static Vardesc * +hash(ht, s) + hashtab *ht; + register char *s; +{ + register int c, x; + register hashentry *h; + char *s0 = s; + + for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1) + x += c; + for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next) + if (!strcmp(s0, h->name)) + return h->vd; + return 0; + } + + hashtab * +mk_hashtab(nl) + Namelist *nl; +{ + int nht, nv; + hashtab *ht; + Vardesc *v, **vd, **vde; + hashentry *he; + + hashtab **x, **x0, *y; + for(x = &nl_cache; y = *x; x0 = x, x = &y->next) + if (nl == y->nl) + return y; + if (n_nlcache >= MAX_NL_CACHE) { + /* discard least recently used namelist hash table */ + y = *x0; + free((char *)y->next); + y->next = 0; + } + else + n_nlcache++; + nv = nl->nvars; + if (nv >= 0x4000) + nht = 0x7fff; + else { + for(nht = 1; nht < nv; nht <<= 1); + nht += nht - 1; + } + ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *) + + nv*sizeof(hashentry)); + if (!ht) + return 0; + he = (hashentry *)&ht->tab[nht]; + ht->nl = nl; + ht->htsize = nht; + ht->next = nl_cache; + nl_cache = ht; + memset((char *)ht->tab, 0, nht*sizeof(hashentry *)); + vd = nl->vars; + vde = vd + nv; + while(vd < vde) { + v = *vd++; + if (!hash(ht, v->name)) { + he->next = *zot; + *zot = he; + he->name = v->name; + he->vd = v; + he++; + } + } + return ht; + } + +static char Alpha[256], Alphanum[256]; + + static void +nl_init() { + register char *s; + register int c; + + if(!init) + f_init(); + for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; ) + Alpha[c] + = Alphanum[c] + = Alpha[c + 'a' - 'A'] + = Alphanum[c + 'a' - 'A'] + = c; + for(s = "0123456789_"; c = *s++; ) + Alphanum[c] = c; + } + +#define GETC(x) (x=(*l_getc)()) +#define Ungetc(x,y) (*l_ungetc)(x,y) + + static int +getname(s, slen) + register char *s; + int slen; +{ + register char *se = s + slen - 1; + register int ch; + + GETC(ch); + if (!(*s++ = Alpha[ch & 0xff])) { + if (ch != EOF) + ch = 115; + err(elist->cierr, ch, "namelist read"); + } + while(*s = Alphanum[GETC(ch) & 0xff]) + if (s < se) + s++; + if (ch == EOF) + err(elist->cierr, ch == EOF ? -1 : 115, "namelist read"); + if (ch > ' ') + Ungetc(ch,cf); + return *s = 0; + } + + static int +getnum(chp, val) + int *chp; + ftnlen *val; +{ + register int ch, sign; + register ftnlen x; + + while(GETC(ch) <= ' ' && ch >= 0); + if (ch == '-') { + sign = 1; + GETC(ch); + } + else { + sign = 0; + if (ch == '+') + GETC(ch); + } + x = ch - '0'; + if (x < 0 || x > 9) + return 115; + while(GETC(ch) >= '0' && ch <= '9') + x = 10*x + ch - '0'; + while(ch <= ' ' && ch >= 0) + GETC(ch); + if (ch == EOF) + return EOF; + *val = sign ? -x : x; + *chp = ch; + return 0; + } + + static int +getdimen(chp, d, delta, extent, x1) + int *chp; + dimen *d; + ftnlen delta, extent, *x1; +{ + register int k; + ftnlen x2, x3; + + if (k = getnum(chp, x1)) + return k; + x3 = 1; + if (*chp == ':') { + if (k = getnum(chp, &x2)) + return k; + x2 -= *x1; + if (*chp == ':') { + if (k = getnum(chp, &x3)) + return k; + if (!x3) + return 123; + x2 /= x3; + } + if (x2 < 0 || x2 >= extent) + return 123; + d->extent = x2 + 1; + } + else + d->extent = 1; + d->curval = 0; + d->delta = delta; + d->stride = x3; + return 0; + } + + static char where0[] = "namelist read start "; + +x_rsne(a) + cilist *a; +{ + int ch, got1, k, n, nd; + Namelist *nl; + static char where[] = "namelist read"; + char buf[64]; + hashtab *ht; + Vardesc *v; + dimen *dn, *dn0, *dn1; + ftnlen *dims, *dims1; + ftnlen b, b0, b1, ex, no, no1, nomax, size, span; + ftnint type; + char *vaddr; + long iva, ivae; + dimen dimens[MAXDIM], substr; + + if (!Alpha['a']) + nl_init(); + reading=1; + formatted=1; + lquit = 0; + lcount = 0; + got1 = 0; + for(;;) switch(GETC(ch)) { + case EOF: + err(a->ciend,(EOF),where0); + case '&': + case '$': + goto have_amp; + default: + if (ch <= ' ' && ch >= 0) + continue; + err(a->cierr, 115, where0); + } + have_amp: + if (ch = getname(buf,sizeof(buf))) + return ch; + nl = (Namelist *)a->cifmt; + if (strcmp(buf, nl->name)) + err(a->cierr, 118, where0); + ht = mk_hashtab(nl); + if (!ht) + err(elist->cierr, 113, where0); + for(;;) { + for(;;) switch(GETC(ch)) { + case EOF: + if (got1) + return 0; + err(a->ciend,(EOF),where0); + case '/': + case '$': + return 0; + default: + if (ch <= ' ' && ch >= 0 || ch == ',') + continue; + Ungetc(ch,cf); + if (ch = getname(buf,sizeof(buf))) + return ch; + goto havename; + } + havename: + v = hash(ht,buf); + if (!v) + err(a->cierr, 119, where); + while(GETC(ch) <= ' ' && ch >= 0); + vaddr = v->addr; + type = v->type; + if (type < 0) { + size = -type; + type = TYCHAR; + } + else + size = typesize[type]; + ivae = size; + iva = 0; + if (ch == '(' /*)*/ ) { + dn = dimens; + if (!(dims = v->dims)) { + if (type != TYCHAR) + err(a->cierr, 122, where); + if (k = getdimen(&ch, dn, (ftnlen)size, + (ftnlen)size, &b)) + err(a->cierr, k, where); + if (ch != ')') + err(a->cierr, 115, where); + b1 = dn->extent; + if (--b < 0 || b + b1 > size) + return 124; + iva += b; + size = b1; + while(GETC(ch) <= ' ' && ch >= 0); + goto scalar; + } + nd = dims[0]; + nomax = span = dims[1]; + ivae = iva + size*nomax; + if (k = getdimen(&ch, dn, size, nomax, &b)) + err(a->cierr, k, where); + no = dn->extent; + b0 = dims[2]; + dims1 = dims += 3; + ex = 1; + for(n = 1; n++ < nd; dims++) { + if (ch != ',') + err(a->cierr, 115, where); + dn1 = dn + 1; + span /= *dims; + if (k = getdimen(&ch, dn1, dn->delta**dims, + span, &b1)) + err(a->cierr, k, where); + ex *= *dims; + b += b1*ex; + no *= dn1->extent; + dn = dn1; + } + if (ch != ')') + err(a->cierr, 115, where); + b -= b0; + if (b < 0 || b >= nomax) + err(a->cierr, 125, where); + iva += size * b; + dims = dims1; + while(GETC(ch) <= ' ' && ch >= 0); + no1 = 1; + dn0 = dimens; + if (type == TYCHAR && ch == '(' /*)*/) { + if (k = getdimen(&ch, &substr, size, size, &b)) + err(a->cierr, k, where); + if (ch != ')') + err(a->cierr, 115, where); + b1 = substr.extent; + if (--b < 0 || b + b1 > size) + return 124; + iva += b; + b0 = size; + size = b1; + while(GETC(ch) <= ' ' && ch >= 0); + if (b1 < b0) + goto delta_adj; + } + for(; dn0 < dn; dn0++) { + if (dn0->extent != *dims++ || dn0->stride != 1) + break; + no1 *= dn0->extent; + } + if (dn0 == dimens && dimens[0].stride == 1) { + no1 = dimens[0].extent; + dn0++; + } + delta_adj: + ex = 0; + for(dn1 = dn0; dn1 <= dn; dn1++) + ex += (dn1->extent-1) + * (dn1->delta *= dn1->stride); + for(dn1 = dn; dn1 > dn0; dn1--) { + ex -= (dn1->extent - 1) * dn1->delta; + dn1->delta -= ex; + } + } + else if (dims = v->dims) { + no = no1 = dims[1]; + ivae = iva + no*size; + } + else + scalar: + no = no1 = 1; + if (ch != '=') + err(a->cierr, 115, where); + got1 = 1; + readloop: + for(;;) { + if (iva >= ivae || iva < 0) + goto mustend; + else if (iva + no1*size > ivae) { + no1 = (ivae - iva)/size; + l_read(&no1, vaddr + iva, size, type); + mustend: + if (GETC(ch) == '/' || ch == '$') + lquit = 1; + else + err(a->cierr, 125, where); + } + else + l_read(&no1, vaddr + iva, size, type); + if (lquit) + return 0; + if ((no -= no1) <= 0) + break; + for(dn1 = dn0; dn1 <= dn; dn1++) { + if (++dn1->curval < dn1->extent) { + iva += dn1->delta; + goto readloop; + } + dn1->curval = 0; + } + break; + } + } + } + + integer +s_rsne(a) + cilist *a; +{ + int n; + extern integer e_rsle(); + external=1; + if(n = c_le(a)) + return n; + if(curunit->uwrt && nowreading(curunit)) + err(a->cierr,errno,where0); + l_getc = t_getc; + l_ungetc = ungetc; + if (n = x_rsne(a)) + return n; + return e_rsle(); + } diff --git a/lang/fortran/lib/libI77/sfe.c b/lang/fortran/lib/libI77/sfe.c new file mode 100644 index 000000000..1ba234293 --- /dev/null +++ b/lang/fortran/lib/libI77/sfe.c @@ -0,0 +1,28 @@ +/* sequential formatted external common routines*/ +#include "f2c.h" +#include "fio.h" + +extern char *fmtbuf; + +integer e_rsfe() +{ int n; + n=en_fio(); + if (cf == stdout) + fflush(stdout); + else if (cf == stderr) + fflush(stderr); + fmtbuf=NULL; + return(n); +} +c_sfe(a) cilist *a; /* check */ +{ unit *p; + if(a->ciunit >= MXUNIT || a->ciunit<0) + err(a->cierr,101,"startio"); + p = &units[a->ciunit]; + if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe") + if(!p->ufmt) err(a->cierr,102,"sfe") + return(0); +} +integer e_wsfe() +{ return(e_rsfe()); +} diff --git a/lang/fortran/lib/libI77/sue.c b/lang/fortran/lib/libI77/sue.c new file mode 100644 index 000000000..77587c136 --- /dev/null +++ b/lang/fortran/lib/libI77/sue.c @@ -0,0 +1,67 @@ +#include "f2c.h" +#include "fio.h" +extern int reclen; +long recloc; + +integer s_rsue(a) cilist *a; +{ + int n; + if(!init) f_init(); + reading=1; + if(n=c_sue(a)) return(n); + recpos=0; + if(curunit->uwrt && nowreading(curunit)) + err(a->cierr, errno, "read start"); + if(fread((char *)&reclen,sizeof(int),1,cf) + != 1) + { if(feof(cf)) + { curunit->uend = 1; + err(a->ciend, EOF, "start"); + } + clearerr(cf); + err(a->cierr, errno, "start"); + } + return(0); +} +integer s_wsue(a) cilist *a; +{ + int n; + if(!init) f_init(); + if(n=c_sue(a)) return(n); + reading=0; + reclen=0; + if(curunit->uwrt != 1 && nowwriting(curunit)) + err(a->cierr, errno, "write start"); + recloc=ftell(cf); + (void) fseek(cf,(long)sizeof(int),SEEK_CUR); + return(0); +} +c_sue(a) cilist *a; +{ + if(a->ciunit >= MXUNIT || a->ciunit < 0) + err(a->cierr,101,"startio"); + external=sequential=1; + formatted=0; + curunit = &units[a->ciunit]; + elist=a; + if(curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit)) + err(a->cierr,114,"sue"); + cf=curunit->ufd; + if(curunit->ufmt) err(a->cierr,103,"sue") + if(!curunit->useek) err(a->cierr,103,"sue") + return(0); +} +integer e_wsue() +{ long loc; + (void) fwrite((char *)&reclen,sizeof(int),1,cf); + loc=ftell(cf); + (void) fseek(cf,recloc,SEEK_SET); + (void) fwrite((char *)&reclen,sizeof(int),1,cf); + (void) fseek(cf,loc,SEEK_SET); + return(0); +} +integer e_rsue() +{ + (void) fseek(cf,(long)(reclen-recpos+sizeof(int)),SEEK_CUR); + return(0); +} diff --git a/lang/fortran/lib/libI77/typesize.c b/lang/fortran/lib/libI77/typesize.c new file mode 100644 index 000000000..4e881e508 --- /dev/null +++ b/lang/fortran/lib/libI77/typesize.c @@ -0,0 +1,6 @@ +#include "f2c.h" + +ftnlen typesize[] = { 0, 0, sizeof(shortint), sizeof(integer), + sizeof(real), sizeof(doublereal), + sizeof(complex), sizeof(doublecomplex), + sizeof(logical), sizeof(char) }; diff --git a/lang/fortran/lib/libI77/uio.c b/lang/fortran/lib/libI77/uio.c new file mode 100644 index 000000000..6dd2d2e7a --- /dev/null +++ b/lang/fortran/lib/libI77/uio.c @@ -0,0 +1,43 @@ +#include "f2c.h" +#include "fio.h" +int reclen; +do_us(number,ptr,len) ftnint *number; ftnlen len; char *ptr; +{ + if(reading) + { + recpos += *number * len; + if(recpos>reclen) + { + err(elist->ciend,(-1), "eof/uio"); + } + (void) fread(ptr,(int)len,(int)(*number),cf); + return(0); + } + else + { + reclen += *number * len; + (void) fwrite(ptr,(int)len,(int)(*number),cf); + return(0); + } +} +integer do_uio(number,ptr,len) ftnint *number; ftnlen len; char *ptr; +{ + if(sequential) + return(do_us(number,ptr,len)); + else return(do_ud(number,ptr,len)); +} +do_ud(number,ptr,len) ftnint *number; ftnlen len; char *ptr; +{ + recpos += *number * len; + if(recpos > curunit->url && curunit->url!=1) + err(elist->cierr,110,"eof/uio"); + if(reading) + { + if(fread(ptr,(int)len,(int)(*number),cf) + != *number) + err(elist->cierr,27,"eof/uio") + else return(0); + } + (void) fwrite(ptr,(int)len,(int)(*number),cf); + return(0); +} diff --git a/lang/fortran/lib/libI77/util.c b/lang/fortran/lib/libI77/util.c new file mode 100644 index 000000000..8357df435 --- /dev/null +++ b/lang/fortran/lib/libI77/util.c @@ -0,0 +1,53 @@ +#ifndef MSDOS +#include "sys/types.h" +#include "sys/stat.h" +#endif +#include "f2c.h" +#include "fio.h" + +g_char(a,alen,b) char *a,*b; ftnlen alen; +{ + char *x = a + alen, *y = b + alen; + + for(;; y--) { + if (x <= a) { + *b = 0; + return; + } + if (*--x != ' ') + break; + } + *y-- = 0; + do *y-- = *x; + while(x-- > a); + } + +b_char(a,b,blen) char *a,*b; ftnlen blen; +{ int i; + for(i=0;iy) for(;num>0;num--) *y++= *x++; + else for(num--;num>=0;num--) *(y+num)= *(x+num); + } + else + { register char *x=a,*y=b; + if(x>y) for(;num>0;num--) *y++= *x++; + else for(num--;num>=0;num--) *(y+num)= *(x+num); + } +} diff --git a/lang/fortran/lib/libI77/wref.c b/lang/fortran/lib/libI77/wref.c new file mode 100644 index 000000000..cecb09069 --- /dev/null +++ b/lang/fortran/lib/libI77/wref.c @@ -0,0 +1,224 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#include "fp.h" +#ifndef VAX +#include "ctype.h" +#endif + +wrt_E(p,w,d,e,len) ufloat *p; ftnlen len; +{ + char buf[FMAX+EXPMAXDIGS+4], *s, *se; + int d1, delta, e1, i, sign, signspace; + double dd; +#ifndef VAX + int e0 = e; +#endif + + if(e <= 0) + e = 2; + if(scale) { + if(scale >= d + 2 || scale <= -d) + goto nogood; + } + if(scale <= 0) + --d; + if (len == sizeof(real)) + dd = p->pf; + else + dd = p->pd; + if (dd >= 0.) { + sign = 0; + signspace = cplus; +#ifndef VAX + if (!dd) + dd = 0.; /* avoid -0 */ +#endif + } + else { + signspace = sign = 1; + dd = -dd; + } + delta = w - (2 /* for the . and the d adjustment above */ + + 2 /* for the E+ */ + signspace + d + e); + if (delta < 0) { +nogood: + while(--w >= 0) + PUT('*'); + return(0); + } + if (scale < 0) + d += scale; + if (d > FMAX) { + d1 = d - FMAX; + d = FMAX; + } + else + d1 = 0; + sprintf(buf,"%#.*E", d, dd); +#ifndef VAX + /* check for NaN, Infinity */ + if (!isdigit(buf[0])) { + delta = w - strlen(buf) - signspace; + if (delta < 0) + goto nogood; + while(--delta >= 0) + PUT(' '); + if (signspace) + PUT(sign ? '-' : '+'); + for(s = buf; *s; s++) + PUT(*s); + return 0; + } +#endif + se = buf + d + 3; + if (scale != 1 && dd) + sprintf(se, "%+.2d", atoi(se) + 1 - scale); + s = ++se; + if (e < 2) { + if (*s != '0') + goto nogood; + } +#ifndef VAX + /* accommodate 3 significant digits in exponent */ + if (s[2]) { +#ifdef Pedantic + if (!e0 && !s[3]) + for(s -= 2, e1 = 2; s[0] = s[1]; s++); + + /* Pedantic gives the behavior that Fortran 77 specifies, */ + /* i.e., requires that E be specified for exponent fields */ + /* of more than 3 digits. With Pedantic undefined, we get */ + /* the behavior that Cray displays -- you get a bigger */ + /* exponent field if it fits. */ +#else + if (!e0) { + for(s -= 2, e1 = 2; s[0] = s[1]; s++) +#ifdef CRAY + delta--; + if ((delta += 4) < 0) + goto nogood +#endif + ; + } +#endif + else if (e0 >= 0) + goto shift; + else + e1 = e; + } + else + shift: +#endif + for(s += 2, e1 = 2; *s; ++e1, ++s) + if (e1 >= e) + goto nogood; + while(--delta >= 0) + PUT(' '); + if (signspace) + PUT(sign ? '-' : '+'); + s = buf; + i = scale; + if (scale <= 0) { + PUT('.'); + for(; i < 0; ++i) + PUT('0'); + PUT(*s); + s += 2; + } + else if (scale > 1) { + PUT(*s); + s += 2; + while(--i > 0) + PUT(*s++); + PUT('.'); + } + if (d1) { + se -= 2; + while(s < se) PUT(*s++); + se += 2; + do PUT('0'); while(--d1 > 0); + } + while(s < se) + PUT(*s++); + if (e < 2) + PUT(s[1]); + else { + while(++e1 <= e) + PUT('0'); + while(*s) + PUT(*s++); + } + return 0; + } + +wrt_F(p,w,d,len) ufloat *p; ftnlen len; +{ + int d1, sign, n; + double x; + char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s; + + x= (len==sizeof(real)?p->pf:p->pd); + if (d < MAXFRACDIGS) + d1 = 0; + else { + d1 = d - MAXFRACDIGS; + d = MAXFRACDIGS; + } + if (x < 0.) + { x = -x; sign = 1; } + else { + sign = 0; +#ifndef VAX + if (!x) + x = 0.; +#endif + } + + if (n = scale) + if (n > 0) + do x *= 10.; while(--n > 0); + else + do x *= 0.1; while(++n < 0); + +#ifdef USE_STRLEN + sprintf(b = buf, "%#.*f", d, x); + n = strlen(b) + d1; +#else + n = sprintf(b = buf, "%#.*f", d, x) + d1; +#endif + + if (buf[0] == '0' && d) + { ++b; --n; } + if (sign) { + /* check for all zeros */ + for(s = b;;) { + while(*s == '0') s++; + switch(*s) { + case '.': + s++; continue; + case 0: + sign = 0; + } + break; + } + } + if (sign || cplus) + ++n; + if (n > w) { + while(--w >= 0) + PUT('*'); + return 0; + } + for(w -= n; --w >= 0; ) + PUT(' '); + if (sign) + PUT('-'); + else if (cplus) + PUT('+'); + while(n = *b++) + PUT(n); + while(--d1 >= 0) + PUT('0'); + return 0; + } diff --git a/lang/fortran/lib/libI77/wrtfmt.c b/lang/fortran/lib/libI77/wrtfmt.c new file mode 100644 index 000000000..8a0766ba2 --- /dev/null +++ b/lang/fortran/lib/libI77/wrtfmt.c @@ -0,0 +1,250 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +extern int cursor; +extern char *icvt(), *ecvt(); +int hiwater; +icilist *svic; +char *icptr; +mv_cur() /* shouldn't use fseek because it insists on calling fflush */ + /* instead we know too much about stdio */ +{ + if(external == 0) { + if(cursor < 0) { + if(hiwater < recpos) + hiwater = recpos; + recpos += cursor; + icptr += cursor; + cursor = 0; + if(recpos < 0) + err(elist->cierr, 110, "left off"); + } + else if(cursor > 0) { + if(recpos + cursor >= svic->icirlen) + err(elist->cierr, 110, "recend"); + if(hiwater <= recpos) + for(; cursor > 0; cursor--) + (*putn)(' '); + else if(hiwater <= recpos + cursor) { + cursor -= hiwater - recpos; + icptr += hiwater - recpos; + recpos = hiwater; + for(; cursor > 0; cursor--) + (*putn)(' '); + } + else { + icptr += cursor; + recpos += cursor; + } + cursor = 0; + } + return(0); + } + if(cursor > 0) { + if(hiwater <= recpos) + for(;cursor>0;cursor--) (*putn)(' '); + else if(hiwater <= recpos + cursor) { +#ifndef NON_UNIX_STDIO + if(cf->_ptr + hiwater - recpos < buf_end(cf)) + cf->_ptr += hiwater - recpos; + else +#endif + (void) fseek(cf, (long) (hiwater - recpos), SEEK_CUR); + cursor -= hiwater - recpos; + recpos = hiwater; + for(; cursor > 0; cursor--) + (*putn)(' '); + } + else { +#ifndef NON_UNIX_STDIO + if(cf->_ptr + cursor < buf_end(cf)) + cf->_ptr += cursor; + else +#endif + (void) fseek(cf, (long)cursor, SEEK_CUR); + recpos += cursor; + } + } + if(cursor<0) + { + if(cursor+recpos<0) err(elist->cierr,110,"left off"); +#ifndef NON_UNIX_STDIO + if(cf->_ptr + cursor >= cf->_base) + cf->_ptr += cursor; + else +#endif + if(curunit && curunit->useek) + (void) fseek(cf,(long)cursor,SEEK_CUR); + else + err(elist->cierr,106,"fmt"); + if(hiwater < recpos) + hiwater = recpos; + recpos += cursor; + cursor=0; + } + return(0); +} +w_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len; +{ + if(cursor && mv_cur()) return(mv_cur()); + switch(p->op) + { + default: + fprintf(stderr,"w_ed, unexpected code: %d\n", p->op); + sig_die(fmtbuf, 1); + case I: return(wrt_I((uint *)ptr,p->p1,len, 10)); + case IM: + return(wrt_IM((uint *)ptr,p->p1,p->p2,len)); + case O: return(wrt_I((uint *)ptr, p->p1, len, 8)); + case L: return(wrt_L((uint *)ptr,p->p1, len)); + case A: return(wrt_A(ptr,len)); + case AW: + return(wrt_AW(ptr,p->p1,len)); + case D: + case E: + case EE: + return(wrt_E((ufloat *)ptr,p->p1,p->p2,p->p3,len)); + case G: + case GE: + return(wrt_G((ufloat *)ptr,p->p1,p->p2,p->p3,len)); + case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2,len)); + } +} +w_ned(p) struct syl *p; +{ + switch(p->op) + { + default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op); + sig_die(fmtbuf, 1); + case SLASH: + return((*donewrec)()); + case T: cursor = p->p1-recpos - 1; + return(1); + case TL: cursor -= p->p1; + if(cursor < -recpos) /* TL1000, 1X */ + cursor = -recpos; + return(1); + case TR: + case X: + cursor += p->p1; + return(1); + case APOS: + return(wrt_AP(*(char **)&p->p2)); + case H: + return(wrt_H(p->p1,*(char **)&p->p2)); + } +} +wrt_I(n,w,len, base) uint *n; ftnlen len; register int base; +{ int ndigit,sign,spare,i; + long x; + char *ans; + if(len==sizeof(integer)) x=n->il; + else if(len == sizeof(char)) x = n->ic; + else x=n->is; + ans=icvt(x,&ndigit,&sign, base); + spare=w-ndigit; + if(sign || cplus) spare--; + if(spare<0) + for(i=0;iil; + else if(len == sizeof(char)) x = n->ic; + else x=n->is; + ans=icvt(x,&ndigit,&sign, 10); + if(sign || cplus) xsign=1; + else xsign=0; + if(ndigit+xsign>w || m+xsign>w) + { for(i=0;i=m) + spare=w-ndigit-xsign; + else + spare=w-m-xsign; + for(i=0;iil; + else if(sz == sizeof(char)) x = n->ic; + else x=n->is; + for(i=0;i 0) (*putn)(*p++); + return(0); +} +wrt_AW(p,w,len) char * p; ftnlen len; +{ + while(w>len) + { w--; + (*putn)(' '); + } + while(w-- > 0) + (*putn)(*p++); + return(0); +} + +wrt_G(p,w,d,e,len) ufloat *p; ftnlen len; +{ double up = 1,x; + int i,oldscale=scale,n,j; + x= len==sizeof(real)?p->pf:p->pd; + if(x < 0 ) x = -x; + if(x<.1) return(wrt_E(p,w,d,e,len)); + for(i=0;i<=d;i++,up*=10) + { if(x>=up) continue; + scale=0; + if(e==0) n=4; + else n=e+2; + i=wrt_F(p,w-n,d-i,len); + for(j=0;jcifmt; + curunit = &units[a->ciunit]; + cf=curunit->ufd; + if(pars_f(fmtbuf)<0) err(a->cierr,100,"startio"); + putn= x_putc; + doed= w_ed; + doned= w_ned; + doend=xw_end; + dorevert=xw_rev; + donewrec=x_wSL; + fmt_bg(); + cplus=0; + cblank=curunit->ublnk; + if(curunit->uwrt != 1 && nowwriting(curunit)) + err(a->cierr,errno,"write start"); + return(0); +} +x_putc(c) +{ + /* this uses \n as an indicator of record-end */ + if(c == '\n' && recpos < hiwater) { /* fseek calls fflush, a loss */ +#ifndef NON_UNIX_STDIO + if(cf->_ptr + hiwater - recpos < buf_end(cf)) + cf->_ptr += hiwater - recpos; + else +#endif + (void) fseek(cf, (long)(hiwater - recpos), SEEK_CUR); + } + putc(c,cf); + recpos++; +} +pr_put(c) +{ static flag new = 1; + recpos++; + if(c=='\n') + { new=1; + putc(c,cf); + } + else if(new==1) + { new=0; + if(c=='0') putc('\n',cf); + else if(c=='1') putc('\f',cf); + } + else putc(c,cf); +} +x_wSL() +{ + (*putn)('\n'); + recpos=0; + cursor = 0; + hiwater = 0; + return(1); +} +xw_end() +{ + if(nonl == 0) + (*putn)('\n'); + hiwater = recpos = cursor = 0; + return(0); +} +xw_rev() +{ + if(workdone) (*putn)('\n'); + hiwater = recpos = cursor = 0; + return(workdone=0); +} diff --git a/lang/fortran/lib/libI77/wsle.c b/lang/fortran/lib/libI77/wsle.c new file mode 100644 index 000000000..d3f6cfecc --- /dev/null +++ b/lang/fortran/lib/libI77/wsle.c @@ -0,0 +1,33 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#include "lio.h" +extern int l_write(), t_putc(), x_wSL(); + +integer s_wsle(a) cilist *a; +{ + int n; + if(!init) f_init(); + if(n=c_le(a)) return(n); + reading=0; + external=1; + formatted=1; + putn = t_putc; + lioproc = l_write; + L_len = LINE; + donewrec = x_wSL; + if(curunit->uwrt != 1 && nowwriting(curunit)) + err(a->cierr, errno, "list output start"); + return(0); + } + +integer e_wsle() +{ + t_putc('\n'); + recpos=0; + if (cf == stdout) + fflush(stdout); + else if (cf == stderr) + fflush(stderr); + return(0); + } diff --git a/lang/fortran/lib/libI77/wsne.c b/lang/fortran/lib/libI77/wsne.c new file mode 100644 index 000000000..95b240a82 --- /dev/null +++ b/lang/fortran/lib/libI77/wsne.c @@ -0,0 +1,27 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" + + integer +s_wsne(a) + cilist *a; +{ + int n; + extern int (*donewrec)(), t_putc(), x_wSL(); + extern integer e_wsle(); + + if(!init) + f_init(); + if(n=c_le(a)) + return(n); + reading=0; + external=1; + formatted=1; + putn = t_putc; + L_len = LINE; + donewrec = x_wSL; + if(curunit->uwrt != 1 && nowwriting(curunit)) + err(a->cierr, errno, "namelist output start"); + x_wsne(a); + return e_wsle(); + } diff --git a/lang/fortran/lib/libI77/xwsne.c b/lang/fortran/lib/libI77/xwsne.c new file mode 100644 index 000000000..4f96d50d1 --- /dev/null +++ b/lang/fortran/lib/libI77/xwsne.c @@ -0,0 +1,53 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#include "fmt.h" + +x_wsne(a) + cilist *a; +{ + Namelist *nl; + char *s; + Vardesc *v, **vd, **vde; + ftnint *number, type; + ftnlen *dims; + ftnlen size; + static ftnint one = 1; + extern ftnlen typesize[]; + + nl = (Namelist *)a->cifmt; + PUT('&'); + for(s = nl->name; *s; s++) + PUT(*s); + PUT(' '); + vd = nl->vars; + vde = vd + nl->nvars; + while(vd < vde) { + v = *vd++; + s = v->name; + if (recpos+strlen(s)+2 >= L_len) + (*donewrec)(); + while(*s) + PUT(*s++); + PUT(' '); + PUT('='); + number = (dims = v->dims) ? dims + 1 : &one; + type = v->type; + if (type < 0) { + size = -type; + type = TYCHAR; + } + else + size = typesize[type]; + l_write(number, v->addr, size, type); + if (vd < vde) { + if (recpos+2 >= L_len) + (*donewrec)(); + PUT(','); + PUT(' '); + } + else if (recpos+1 >= L_len) + (*donewrec)(); + } + PUT('/'); + }