From a17c780665c109829426e062df4d75ff950725e0 Mon Sep 17 00:00:00 2001 From: pvtroshin Date: Thu, 3 Feb 2011 13:16:41 +0000 Subject: [PATCH] Adding DisEMBL dependency Tisean executable git-svn-id: link to svn.lifesci.dundee.ac.uk/svn/barton/ptroshin/JABA2@3667 e3abac25-378b-4346-85de-24260fe3988d --- binaries/src/disembl/Tisean_3.0.1/COPYING | 339 ++++ binaries/src/disembl/Tisean_3.0.1/INSTALL | 8 + binaries/src/disembl/Tisean_3.0.1/Makefile.in | 84 + binaries/src/disembl/Tisean_3.0.1/README | 34 + binaries/src/disembl/Tisean_3.0.1/autoscan.log | 483 ++++++ binaries/src/disembl/Tisean_3.0.1/bins.sh | 64 + binaries/src/disembl/Tisean_3.0.1/configure | 1645 ++++++++++++++++++++ binaries/src/disembl/Tisean_3.0.1/configure.in | 247 +++ binaries/src/disembl/Tisean_3.0.1/configure.scan | 41 + binaries/src/disembl/Tisean_3.0.1/index.html | 7 + binaries/src/disembl/Tisean_3.0.1/install-sh | 238 +++ binaries/src/disembl/Tisean_3.0.1/logo | 14 + .../src/disembl/Tisean_3.0.1/source_c/Makefile.in | 47 + .../src/disembl/Tisean_3.0.1/source_c/ar-model.c | 395 +++++ .../disembl/Tisean_3.0.1/source_c/arima-model.c | 721 +++++++++ binaries/src/disembl/Tisean_3.0.1/source_c/av-d2.c | 188 +++ .../src/disembl/Tisean_3.0.1/source_c/boxcount.c | 369 +++++ binaries/src/disembl/Tisean_3.0.1/source_c/corr.c | 179 +++ binaries/src/disembl/Tisean_3.0.1/source_c/d2.c | 587 +++++++ binaries/src/disembl/Tisean_3.0.1/source_c/delay.c | 331 ++++ .../src/disembl/Tisean_3.0.1/source_c/extrema.c | 225 +++ .../disembl/Tisean_3.0.1/source_c/false_nearest.c | 328 ++++ binaries/src/disembl/Tisean_3.0.1/source_c/fsle.c | 304 ++++ binaries/src/disembl/Tisean_3.0.1/source_c/ghkss.c | 503 ++++++ .../src/disembl/Tisean_3.0.1/source_c/histogram.c | 170 ++ .../src/disembl/Tisean_3.0.1/source_c/lfo-ar.c | 390 +++++ .../src/disembl/Tisean_3.0.1/source_c/lfo-run.c | 456 ++++++ .../src/disembl/Tisean_3.0.1/source_c/lfo-test.c | 462 ++++++ .../src/disembl/Tisean_3.0.1/source_c/low121.c | 173 ++ .../src/disembl/Tisean_3.0.1/source_c/lyap_k.c | 341 ++++ .../src/disembl/Tisean_3.0.1/source_c/lyap_r.c | 251 +++ .../src/disembl/Tisean_3.0.1/source_c/lyap_spec.c | 574 +++++++ .../src/disembl/Tisean_3.0.1/source_c/lzo-gm.c | 293 ++++ .../src/disembl/Tisean_3.0.1/source_c/lzo-run.c | 411 +++++ .../src/disembl/Tisean_3.0.1/source_c/lzo-test.c | 345 ++++ .../src/disembl/Tisean_3.0.1/source_c/makenoise.c | 254 +++ .../src/disembl/Tisean_3.0.1/source_c/mem_spec.c | 242 +++ .../src/disembl/Tisean_3.0.1/source_c/mutual.c | 206 +++ binaries/src/disembl/Tisean_3.0.1/source_c/new.tgz | Bin 0 -> 5609 bytes .../src/disembl/Tisean_3.0.1/source_c/nrlazy.c | 383 +++++ .../src/disembl/Tisean_3.0.1/source_c/nstat_z.c | 486 ++++++ binaries/src/disembl/Tisean_3.0.1/source_c/pca.c | 329 ++++ .../src/disembl/Tisean_3.0.1/source_c/poincare.c | 241 +++ .../src/disembl/Tisean_3.0.1/source_c/polyback.c | 355 +++++ .../src/disembl/Tisean_3.0.1/source_c/polynom.c | 322 ++++ .../src/disembl/Tisean_3.0.1/source_c/polynomp.c | 299 ++++ .../src/disembl/Tisean_3.0.1/source_c/polypar.c | 121 ++ binaries/src/disembl/Tisean_3.0.1/source_c/rbf.c | 383 +++++ .../src/disembl/Tisean_3.0.1/source_c/recurr.c | 225 +++ .../src/disembl/Tisean_3.0.1/source_c/resample.c | 174 +++ .../src/disembl/Tisean_3.0.1/source_c/rescale.c | 185 +++ .../Tisean_3.0.1/source_c/routines/Makefile.in | 21 + .../Tisean_3.0.1/source_c/routines/arima.tgz | Bin 0 -> 5667 bytes .../Tisean_3.0.1/source_c/routines/check_alloc.c | 31 + .../Tisean_3.0.1/source_c/routines/check_option.c | 252 +++ .../Tisean_3.0.1/source_c/routines/diffc.log | 11 + .../disembl/Tisean_3.0.1/source_c/routines/eigen.c | 522 +++++++ .../source_c/routines/exclude_interval.c | 39 + .../source_c/routines/find_multi_neighbors.c | 59 + .../source_c/routines/find_neighbors.c | 55 + .../source_c/routines/get_multi_series.c | 190 +++ .../Tisean_3.0.1/source_c/routines/get_series.c | 110 ++ .../Tisean_3.0.1/source_c/routines/invert_matrix.c | 65 + .../Tisean_3.0.1/source_c/routines/make_box.c | 38 + .../source_c/routines/make_multi_box.c | 39 + .../source_c/routines/make_multi_box2.c | 44 + .../source_c/routines/make_multi_index.c | 50 + .../Tisean_3.0.1/source_c/routines/myfgets.c | 54 + .../disembl/Tisean_3.0.1/source_c/routines/rand.c | 157 ++ .../Tisean_3.0.1/source_c/routines/rand_arb_dist.c | 94 ++ .../Tisean_3.0.1/source_c/routines/rescale_data.c | 50 + .../Tisean_3.0.1/source_c/routines/scan_help.c | 33 + .../source_c/routines/search_datafile.c | 125 ++ .../Tisean_3.0.1/source_c/routines/solvele.c | 69 + .../Tisean_3.0.1/source_c/routines/test_outfile.c | 35 + .../Tisean_3.0.1/source_c/routines/tisean_cec.h | 85 + .../disembl/Tisean_3.0.1/source_c/routines/tsa.h | 105 ++ .../Tisean_3.0.1/source_c/routines/variance.c | 45 + .../Tisean_3.0.1/source_c/routines/what_i_do.c | 31 + .../src/disembl/Tisean_3.0.1/source_c/sav_gol.c | 257 +++ binaries/src/disembl/Tisean_3.0.1/source_c/xcor.c | 186 +++ binaries/src/disembl/Tisean_3.0.1/source_c/xzero.c | 237 +++ .../src/disembl/Tisean_3.0.1/source_f/Makefile.in | 71 + .../src/disembl/Tisean_3.0.1/source_f/addnoise.f | 102 ++ binaries/src/disembl/Tisean_3.0.1/source_f/any_s.f | 43 + .../src/disembl/Tisean_3.0.1/source_f/ar-run.f | 99 ++ .../src/disembl/Tisean_3.0.1/source_f/arguments.f | 159 ++ .../src/disembl/Tisean_3.0.1/source_f/autocor.f | 96 ++ binaries/src/disembl/Tisean_3.0.1/source_f/c1.f | 92 ++ binaries/src/disembl/Tisean_3.0.1/source_f/c2d.f | 90 ++ binaries/src/disembl/Tisean_3.0.1/source_f/c2g.f | 109 ++ .../src/disembl/Tisean_3.0.1/source_f/c2naive.f | 120 ++ binaries/src/disembl/Tisean_3.0.1/source_f/c2t.f | 81 + .../src/disembl/Tisean_3.0.1/source_f/choose.f | 60 + .../src/disembl/Tisean_3.0.1/source_f/cluster.f | 195 +++ .../disembl/Tisean_3.0.1/source_f/commandline.f | 162 ++ .../src/disembl/Tisean_3.0.1/source_f/compare.f | 72 + binaries/src/disembl/Tisean_3.0.1/source_f/d1.f | 116 ++ .../src/disembl/Tisean_3.0.1/source_f/endtoend.f | 120 ++ .../src/disembl/Tisean_3.0.1/source_f/events.f | 65 + binaries/src/disembl/Tisean_3.0.1/source_f/gpl.txt | 21 + binaries/src/disembl/Tisean_3.0.1/source_f/help.f | 80 + binaries/src/disembl/Tisean_3.0.1/source_f/henon.f | 69 + binaries/src/disembl/Tisean_3.0.1/source_f/ikeda.f | 75 + .../src/disembl/Tisean_3.0.1/source_f/intervals.f | 62 + .../disembl/Tisean_3.0.1/source_f/istdio_temp.f | 44 + binaries/src/disembl/Tisean_3.0.1/source_f/lazy.f | 109 ++ .../src/disembl/Tisean_3.0.1/source_f/lorenz.f | 311 ++++ binaries/src/disembl/Tisean_3.0.1/source_f/neigh.f | 182 +++ binaries/src/disembl/Tisean_3.0.1/source_f/nmore.f | 58 + .../src/disembl/Tisean_3.0.1/source_f/normal.f | 70 + binaries/src/disembl/Tisean_3.0.1/source_f/notch.f | 86 + binaries/src/disembl/Tisean_3.0.1/source_f/pc.f | 96 ++ .../src/disembl/Tisean_3.0.1/source_f/predict.f | 104 ++ .../src/disembl/Tisean_3.0.1/source_f/project.f | 172 ++ .../Tisean_3.0.1/source_f/randomize/Makefile.in | 53 + .../Tisean_3.0.1/source_f/randomize/cool/exp.f | 127 ++ .../Tisean_3.0.1/source_f/randomize/cost/auto.f | 174 +++ .../Tisean_3.0.1/source_f/randomize/cost/autop.f | 181 +++ .../source_f/randomize/cost/spikeauto.f | 265 ++++ .../source_f/randomize/cost/spikespec.f | 251 +++ .../Tisean_3.0.1/source_f/randomize/cost/uneven.f | 260 ++++ .../Tisean_3.0.1/source_f/randomize/perm/event.f | 81 + .../Tisean_3.0.1/source_f/randomize/perm/random.f | 109 ++ .../Tisean_3.0.1/source_f/randomize/randomize.f | 127 ++ binaries/src/disembl/Tisean_3.0.1/source_f/rank.f | 153 ++ .../src/disembl/Tisean_3.0.1/source_f/readfile.f | 186 +++ binaries/src/disembl/Tisean_3.0.1/source_f/rms.f | 82 + .../Tisean_3.0.1/source_f/slatec/Makefile.in | 27 + .../disembl/Tisean_3.0.1/source_f/slatec/chkder.f | 158 ++ .../disembl/Tisean_3.0.1/source_f/slatec/d1mach.f | 19 + .../disembl/Tisean_3.0.1/source_f/slatec/dqk15.f | 185 +++ .../disembl/Tisean_3.0.1/source_f/slatec/enorm.f | 117 ++ .../disembl/Tisean_3.0.1/source_f/slatec/fdjac3.f | 114 ++ .../disembl/Tisean_3.0.1/source_f/slatec/fdump.f | 31 + .../disembl/Tisean_3.0.1/source_f/slatec/i1mach.f | 142 ++ .../disembl/Tisean_3.0.1/source_f/slatec/j4save.f | 65 + .../disembl/Tisean_3.0.1/source_f/slatec/lmpar.f | 267 ++++ .../disembl/Tisean_3.0.1/source_f/slatec/pythag.f | 39 + .../disembl/Tisean_3.0.1/source_f/slatec/qrfac.f | 170 ++ .../disembl/Tisean_3.0.1/source_f/slatec/qrsolv.f | 198 +++ .../disembl/Tisean_3.0.1/source_f/slatec/r1mach.f | 21 + .../disembl/Tisean_3.0.1/source_f/slatec/radb2.f | 61 + .../disembl/Tisean_3.0.1/source_f/slatec/radb3.f | 85 + .../disembl/Tisean_3.0.1/source_f/slatec/radb4.f | 109 ++ .../disembl/Tisean_3.0.1/source_f/slatec/radb5.f | 132 ++ .../disembl/Tisean_3.0.1/source_f/slatec/radbg.f | 189 +++ .../disembl/Tisean_3.0.1/source_f/slatec/radf2.f | 61 + .../disembl/Tisean_3.0.1/source_f/slatec/radf3.f | 83 + .../disembl/Tisean_3.0.1/source_f/slatec/radf4.f | 105 ++ .../disembl/Tisean_3.0.1/source_f/slatec/radf5.f | 128 ++ .../disembl/Tisean_3.0.1/source_f/slatec/radfg.f | 194 +++ .../disembl/Tisean_3.0.1/source_f/slatec/rand.f | 122 ++ .../disembl/Tisean_3.0.1/source_f/slatec/rfftb1.f | 143 ++ .../disembl/Tisean_3.0.1/source_f/slatec/rfftf1.f | 144 ++ .../disembl/Tisean_3.0.1/source_f/slatec/rffti1.f | 110 ++ .../disembl/Tisean_3.0.1/source_f/slatec/rgauss.f | 43 + .../src/disembl/Tisean_3.0.1/source_f/slatec/rs.f | 90 ++ .../disembl/Tisean_3.0.1/source_f/slatec/rwupdt.f | 120 ++ .../disembl/Tisean_3.0.1/source_f/slatec/snls1.f | 1023 ++++++++++++ .../disembl/Tisean_3.0.1/source_f/slatec/tql2.f | 203 +++ .../disembl/Tisean_3.0.1/source_f/slatec/tqlrat.f | 165 ++ .../disembl/Tisean_3.0.1/source_f/slatec/tred1.f | 142 ++ .../disembl/Tisean_3.0.1/source_f/slatec/tred2.f | 166 ++ .../disembl/Tisean_3.0.1/source_f/slatec/xercnt.f | 62 + .../disembl/Tisean_3.0.1/source_f/slatec/xerhlt.f | 39 + .../disembl/Tisean_3.0.1/source_f/slatec/xermsg.f | 364 +++++ .../disembl/Tisean_3.0.1/source_f/slatec/xerprn.f | 228 +++ .../disembl/Tisean_3.0.1/source_f/slatec/xersve.f | 155 ++ .../disembl/Tisean_3.0.1/source_f/slatec/xgetua.f | 51 + .../src/disembl/Tisean_3.0.1/source_f/spectrum.f | 79 + .../src/disembl/Tisean_3.0.1/source_f/spikeauto.f | 81 + .../src/disembl/Tisean_3.0.1/source_f/spikespec.f | 105 ++ .../src/disembl/Tisean_3.0.1/source_f/store_spec.f | 49 + binaries/src/disembl/Tisean_3.0.1/source_f/stp.f | 104 ++ .../src/disembl/Tisean_3.0.1/source_f/surrogates.f | 179 +++ .../src/disembl/Tisean_3.0.1/source_f/timerev.f | 61 + .../src/disembl/Tisean_3.0.1/source_f/tospec.f | 53 + .../src/disembl/Tisean_3.0.1/source_f/totospec.f | 48 + binaries/src/disembl/Tisean_3.0.1/source_f/upo.f | 268 ++++ .../src/disembl/Tisean_3.0.1/source_f/upoembed.f | 69 + .../src/disembl/Tisean_3.0.1/source_f/verbose.f | 98 ++ .../src/disembl/Tisean_3.0.1/source_f/wiener1.f | 85 + .../src/disembl/Tisean_3.0.1/source_f/wiener2.f | 95 ++ binaries/src/disembl/Tisean_3.0.1/source_f/xc2.f | 244 +++ .../src/disembl/Tisean_3.0.1/source_f/xreadfile.f | 103 ++ .../src/disembl/Tisean_3.0.1/source_f/xrecur.f | 402 +++++ binaries/src/disembl/Tisean_3.0.1/test.f | 6 + binaries/src/disembl/disembl | Bin 720839 -> 720839 bytes 189 files changed, 32180 insertions(+) create mode 100644 binaries/src/disembl/Tisean_3.0.1/COPYING create mode 100644 binaries/src/disembl/Tisean_3.0.1/INSTALL create mode 100644 binaries/src/disembl/Tisean_3.0.1/Makefile.in create mode 100644 binaries/src/disembl/Tisean_3.0.1/README create mode 100644 binaries/src/disembl/Tisean_3.0.1/TODO create mode 100644 binaries/src/disembl/Tisean_3.0.1/autoscan.log create mode 100644 binaries/src/disembl/Tisean_3.0.1/bins.sh create mode 100644 binaries/src/disembl/Tisean_3.0.1/configure create mode 100644 binaries/src/disembl/Tisean_3.0.1/configure.in create mode 100644 binaries/src/disembl/Tisean_3.0.1/configure.scan create mode 100644 binaries/src/disembl/Tisean_3.0.1/index.html create mode 100644 binaries/src/disembl/Tisean_3.0.1/install-sh create mode 100644 binaries/src/disembl/Tisean_3.0.1/logo create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/Makefile.in create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/ar-model.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/arima-model.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/av-d2.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/boxcount.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/corr.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/d2.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/delay.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/extrema.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/false_nearest.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/fsle.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/ghkss.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/histogram.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/lfo-ar.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/lfo-run.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/lfo-test.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/low121.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/lyap_k.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/lyap_r.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/lyap_spec.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/lzo-gm.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/lzo-run.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/lzo-test.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/makenoise.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/mem_spec.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/mutual.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/new.tgz create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/nrlazy.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/nstat_z.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/pca.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/poincare.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/polyback.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/polynom.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/polynomp.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/polypar.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/rbf.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/recurr.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/resample.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/rescale.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/Makefile.in create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/arima.tgz create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/check_alloc.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/check_option.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/diffc.log create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/diffh.log create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/eigen.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/exclude_interval.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/find_multi_neighbors.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/find_neighbors.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/get_multi_series.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/get_series.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/invert_matrix.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/make_box.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/make_multi_box.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/make_multi_box2.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/make_multi_index.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/myfgets.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/rand.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/rand_arb_dist.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/rescale_data.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/scan_help.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/search_datafile.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/solvele.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/test_outfile.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/tisean_cec.h create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/tsa.h create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/variance.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/routines/what_i_do.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/sav_gol.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/xcor.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_c/xzero.c create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/Makefile.in create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/addnoise.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/any_s.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/ar-run.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/arguments.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/autocor.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/c1.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/c2d.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/c2g.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/c2naive.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/c2t.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/choose.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/cluster.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/commandline.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/compare.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/d1.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/endtoend.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/events.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/gpl.txt create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/help.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/henon.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/ikeda.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/intervals.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/istdio_temp.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/lazy.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/lorenz.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/neigh.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/nmore.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/normal.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/notch.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/pc.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/predict.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/project.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/randomize/Makefile.in create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cool/exp.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/auto.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/autop.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/spikeauto.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/spikespec.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/uneven.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/randomize/perm/event.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/randomize/perm/random.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/randomize/randomize.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/rank.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/readfile.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/rms.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/Makefile.in create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/chkder.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/d1mach.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/dqk15.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/enorm.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/fdjac3.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/fdump.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/i1mach.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/j4save.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/lmpar.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/pythag.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/qrfac.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/qrsolv.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/r1mach.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb2.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb3.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb4.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb5.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radbg.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf2.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf3.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf4.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf5.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radfg.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rand.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rfftb1.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rfftf1.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rffti1.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rgauss.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rs.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rwupdt.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/snls1.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tql2.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tqlrat.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tred1.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tred2.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xercnt.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xerhlt.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xermsg.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xerprn.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xersve.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xgetua.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/spectrum.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/spikeauto.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/spikespec.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/store_spec.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/stp.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/surrogates.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/timerev.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/tospec.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/totospec.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/upo.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/upoembed.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/verbose.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/wiener1.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/wiener2.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/xc2.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/xreadfile.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/source_f/xrecur.f create mode 100644 binaries/src/disembl/Tisean_3.0.1/test.f diff --git a/binaries/src/disembl/Tisean_3.0.1/COPYING b/binaries/src/disembl/Tisean_3.0.1/COPYING new file mode 100644 index 0000000..d511905 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/COPYING @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/binaries/src/disembl/Tisean_3.0.1/INSTALL b/binaries/src/disembl/Tisean_3.0.1/INSTALL new file mode 100644 index 0000000..17d4019 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/INSTALL @@ -0,0 +1,8 @@ +To install type + +./configue +make +make install + +and observe the warnings :-) + diff --git a/binaries/src/disembl/Tisean_3.0.1/Makefile.in b/binaries/src/disembl/Tisean_3.0.1/Makefile.in new file mode 100644 index 0000000..c1f3e0c --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/Makefile.in @@ -0,0 +1,84 @@ +SHELL = /bin/sh + +prefix = @prefix@ +exec_prefix = @exec_prefix@ +BINDIR = ${exec_prefix}/@bindir@ +CC = @CC@ +FC = @FC@ +HAVE_NR = @HAVE_NR@ + +all: + @head -20 README + -if test -n "${FC}"; then (cd source_f && $(MAKE) $@); fi + -if test -n "${CC}"; then (cd source_c && $(MAKE) $@); fi + +install: do_install missing + @echo "******************************************************************" + @echo "the following programs have been installed in" ${BINDIR} + @echo "type" + @echo " $$ progname -h" + @echo "for individual options" + @echo "" + @grep Usage install.log | sed "s/ *Usage./ /" + @echo " (written to install.log)" + @echo "" + -@if test -s missing.log; then \ + echo "the following programs could not be made/installed"; \ + sed "s/^/ /" missing.log; \ + echo " (written to missing.log)"; \ + echo ""; \ + fi + @echo "browse index.html for documentation" + +do_install: + @rm -f install.log + @test -d ${BINDIR} || (echo "${BINDIR} does not exist") + @test -d ${BINDIR} -a -n "${FC}" && (cd source_f && $(MAKE) install) + @test -d ${BINDIR} -a -n "${CC}" && (cd source_c && $(MAKE) install) + +missing: + @rm -f missing.log + -if test -n "${FC}"; then (cd source_f && $(MAKE) $@); fi + -if test -n "${CC}"; then (cd source_c && $(MAKE) $@); fi + +uninstall: + -if test -n "${FC}"; then (cd source_f && $(MAKE) $@); fi + -if test -n "${CC}"; then (cd source_c && $(MAKE) $@); fi + +clean: + -(cd source_f && $(MAKE) $@) + -(cd source_c && $(MAKE) $@) + -@rm -f install.log missing.log config.* + -find . \( -name "*~" -o -name "#*#" -o -name "*.o" \ + -o -name "lib*.a" \) -exec rm -f {} \; + +mproper: clean + -rm -f *.zip *.tar.gz *.tar.bz2 *.ZIP + -find . \( -name "Makefile" -o -name "stdin_*" -o -name tr \ + \) -exec rm -f {} \; + +package: zip gz bzip2 + +zip: mproper + -(file=`basename $$PWD`; \ + cd `dirname $$PWD`; \ + rm -f $$file.zip; \ + zip -r $$file.zip $$file; \ + cd $$file; \ + ls -l `dirname $$PWD`/$$file.zip ) + +gz: mproper + -(file=`basename $$PWD`; \ + cd `dirname $$PWD`; \ + tar -vchf $$file.tar $$file; \ + gzip -vf $$file.tar; \ + cd $$file; \ + ls -l `dirname $$PWD`/$$file.tar.gz ) + +bzip2: mproper + -(file=`basename $$PWD`; \ + cd `dirname $$PWD`; \ + tar -vchf $$file.tar $$file; \ + bzip2 -vf $$file.tar; \ + cd $$file; \ + ls -l `dirname $$PWD`/$$file.tar.bz2 ) diff --git a/binaries/src/disembl/Tisean_3.0.1/README b/binaries/src/disembl/Tisean_3.0.1/README new file mode 100644 index 0000000..274beb5 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/README @@ -0,0 +1,34 @@ +_______________________________________________________________________________ + + _/_/_/_/_/ _/ _/_/_/ _/_/_/_/ _/_/ _/ _/ + _/ _/ _/ _/ _/ _/ _/ _/ _/ + _/ _/ _/ _/ _/ _/ _/_/ _/ + _/ _/ _/_/_/ _/_/_/_/ _/_/_/_/ _/ _/ _/ + _/ _/ _/ _/ _/ _/ _/ _/_/ + _/ _/ _/ _/ _/ _/ _/ _/ _/ + _/ _/ _/_/_/ _/_/_/_/ _/ _/ _/ _/ + + Nonlinear time series project + Copyright (C) Rainer Hegger & Thomas Schreiber (1998-2007) +_______________________________________________________________________________ + +All programs are given WITHOUT ANY WARRANTY; without even the implied +warranty of merchantability or fitness for a particular purpose. If you decide +to use them, you do so AT YOUR OWN RISK. + +The copyright to each program is held by the person named in the source code. +You may use and refer to them as you do with any scientific publication. + +** To get started, use a html browser and view the documentation, e.g. + +> netscape index.html + +** To install type + +> ./configue +> make +> make install + +and observe the warnings :-) + +Have fun. diff --git a/binaries/src/disembl/Tisean_3.0.1/TODO b/binaries/src/disembl/Tisean_3.0.1/TODO new file mode 100644 index 0000000..e69de29 diff --git a/binaries/src/disembl/Tisean_3.0.1/autoscan.log b/binaries/src/disembl/Tisean_3.0.1/autoscan.log new file mode 100644 index 0000000..4d3dc37 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/autoscan.log @@ -0,0 +1,483 @@ +autoscan: warning: missing AC_CHECK_FUNCS([pow]) wanted by: + source_c/lyap_k.c:292 + source_c/lyap_k.c:298 + source_c/sav_gol.c:94 + source_c/sav_gol.c:103 + source_c/d2.c:381 + source_c/polynom.c:282 + source_c/resample.c:113 + source_c/resample.c:144 + source_c/boxcount.c:138 + source_c/boxcount.c:187 + source_c/boxcount.c:286 + unsupported/d2.c:307 + unsupported/lyap_k.cc:268 + unsupported/lyap_k.cc:272 +autoscan: warning: missing AC_CHECK_FUNCS([sqrt]) wanted by: + source_c/ghkss.c:193 + source_c/ghkss.c:268 + source_c/fsle.c:228 + source_c/mem_spec.c:187 + source_c/onestep.c:225 + source_c/onestep.c:232 + source_c/ll-ar.c:341 + source_c/ll-ar.c:342 + source_c/false_nearest.c:273 + source_c/false_nearest.c:285 + source_c/false_nearest.c:290 + source_c/polyback.c:147 + source_c/nstat_z.c:431 + source_c/nstat_z.c:434 + source_c/rbf.c:97 + source_c/rbf.c:134 + source_c/rbf.c:206 + source_c/rbf.c:331 + source_c/rbf.c:344 + source_c/lm-ga.c:234 + source_c/lm-ga.c:235 + source_c/lyap_spec.c:309 + source_c/lyap_spec.c:526 + source_c/lyap_spec.c:530 + source_c/lyap_spec.c:539 + source_c/lyap_spec.c:543 + source_c/xzero.c:205 + source_c/xzero.c:213 + source_c/ar-model.c:171 + source_c/ar-model.c:293 + source_c/ar-model.c:327 + source_c/zeroth.c:264 + source_c/zeroth.c:286 + source_c/polynom.c:288 + source_c/polynom.c:292 + source_c/polynomp.c:146 + source_c/makenoise.c:109 + source_c/arima-model.c:236 + source_c/arima-model.c:489 + source_c/arima-model.c:515 + source_c/arima-model.c:578 + source_c/routines/eigen.c:17 + source_c/routines/eigen.c:19 + source_c/routines/eigen.c:41 + source_c/routines/eigen.c:41 + source_c/routines/variance.c:20 + source_c/routines/rand.c:123 + unsupported/eigen.c:35 + unsupported/eigen.c:37 + unsupported/eigen.c:59 + unsupported/eigen.c:59 + unsupported/dft.c:36 + unsupported/dft.c:65 + unsupported/noise.c:109 + unsupported/sing.c:641 + unsupported/rand.c:139 + unsupported/surrogates.c:121 + unsupported/surrogates.c:122 +autoscan: warning: missing AC_CHECK_FUNCS([strrchr]) wanted by: + unsupported/arguments.c:176 + unsupported/arguments.c:179 +autoscan: warning: missing AC_CHECK_FUNCS([strstr]) wanted by: + source_c/av-d2.c:117 +autoscan: warning: missing AC_CHECK_HEADERS([stddef.h]) wanted by: + source_c/routines/eigen.c:4 + unsupported/eigen.c:3 + unsupported/clean.c:3 + unsupported/dft.c:5 + unsupported/surro.c:5 + unsupported/noise.c:8 + unsupported/timerev.c:10 + unsupported/sing.c:42 + unsupported/arguments.c:6 + unsupported/autocor3.c:10 + unsupported/surrogates.c:11 +autoscan: warning: missing AC_FUNC_ERROR_AT_LINE wanted by: + unsupported/make_ps.cc:29 + unsupported/make_ps.cc:151 +autoscan: warning: missing AC_FUNC_MALLOC wanted by: + source_c/polypar.c:91 + source_c/recurr.c:197 + source_c/recurr.c:198 + source_c/recurr.c:200 + source_c/ghkss.c:168 + source_c/ghkss.c:270 + source_c/ghkss.c:272 + source_c/ghkss.c:274 + source_c/ghkss.c:275 + source_c/ghkss.c:277 + source_c/ghkss.c:289 + source_c/ghkss.c:291 + source_c/ghkss.c:292 + source_c/ghkss.c:293 + source_c/ghkss.c:295 + source_c/ghkss.c:296 + source_c/ghkss.c:297 + source_c/ghkss.c:298 + source_c/ghkss.c:299 + source_c/ghkss.c:301 + source_c/fsle.c:231 + source_c/fsle.c:239 + source_c/fsle.c:240 + source_c/mem_spec.c:78 + source_c/mem_spec.c:79 + source_c/mem_spec.c:171 + source_c/onestep.c:99 + source_c/onestep.c:100 + source_c/onestep.c:102 + source_c/onestep.c:178 + source_c/onestep.c:183 + source_c/onestep.c:184 + source_c/onestep.c:185 + source_c/onestep.c:186 + source_c/onestep.c:187 + source_c/onestep.c:189 + source_c/ll-ar.c:273 + source_c/ll-ar.c:274 + source_c/ll-ar.c:275 + source_c/ll-ar.c:276 + source_c/ll-ar.c:278 + source_c/ll-ar.c:279 + source_c/ll-ar.c:280 + source_c/ll-ar.c:281 + source_c/ll-ar.c:283 + source_c/ll-ar.c:284 + source_c/ll-ar.c:285 + source_c/ll-ar.c:286 + source_c/ll-ar.c:287 + source_c/ll-ar.c:288 + source_c/ll-ar.c:289 + source_c/false_nearest.c:223 + source_c/false_nearest.c:224 + source_c/false_nearest.c:225 + source_c/false_nearest.c:227 + source_c/false_nearest.c:238 + source_c/false_nearest.c:239 + source_c/lyap_k.c:170 + source_c/lyap_k.c:171 + source_c/lyap_k.c:173 + source_c/lyap_k.c:174 + source_c/lyap_k.c:176 + source_c/lyap_k.c:277 + source_c/lyap_k.c:278 + source_c/lyap_k.c:279 + source_c/lyap_k.c:281 + source_c/lyap_k.c:282 + source_c/lyap_k.c:284 + source_c/lyap_k.c:285 + source_c/lyap_k.c:287 + source_c/polyback.c:99 + source_c/polyback.c:100 + source_c/polyback.c:102 + source_c/polyback.c:205 + source_c/polyback.c:207 + source_c/polyback.c:211 + source_c/polyback.c:221 + source_c/polyback.c:222 + source_c/polyback.c:225 + source_c/polyback.c:258 + source_c/polyback.c:259 + source_c/polyback.c:261 + source_c/lyap_r.c:198 + source_c/lyap_r.c:199 + source_c/lyap_r.c:200 + source_c/lyap_r.c:201 + source_c/nstat_z.c:139 + source_c/nstat_z.c:234 + source_c/nstat_z.c:235 + source_c/nstat_z.c:238 + source_c/nstat_z.c:240 + source_c/nstat_z.c:340 + source_c/nstat_z.c:341 + source_c/nstat_z.c:342 + source_c/nstat_z.c:343 + source_c/nstat_z.c:344 + source_c/nstat_z.c:347 + source_c/nstat_z.c:358 + source_c/nrlazy.c:192 + source_c/nrlazy.c:193 + source_c/nrlazy.c:204 + source_c/nrlazy.c:205 + source_c/nrlazy.c:206 + source_c/nrlazy.c:208 + source_c/nrlazy.c:210 + source_c/nrlazy.c:211 + source_c/nrlazy.c:213 + source_c/nrlazy.c:214 + source_c/nrlazy.c:237 + source_c/rbf.c:119 + source_c/rbf.c:151 + source_c/rbf.c:153 + source_c/rbf.c:154 + source_c/rbf.c:215 + source_c/rbf.c:277 + source_c/rbf.c:278 + source_c/rbf.c:280 + source_c/low121.c:102 + source_c/sav_gol.c:83 + source_c/sav_gol.c:85 + source_c/sav_gol.c:86 + source_c/sav_gol.c:88 + source_c/lm-ga.c:176 + source_c/lm-ga.c:177 + source_c/lm-ga.c:178 + source_c/lm-ga.c:179 + source_c/lm-ga.c:181 + source_c/lm-ga.c:182 + source_c/lm-ga.c:183 + source_c/lm-ga.c:184 + source_c/lm-ga.c:185 + source_c/pca.c:119 + source_c/pca.c:120 + source_c/pca.c:121 + source_c/pca.c:122 + source_c/pca.c:124 + source_c/pca.c:208 + source_c/pca.c:301 + source_c/mutual.c:145 + source_c/mutual.c:146 + source_c/mutual.c:147 + source_c/mutual.c:149 + source_c/mutual.c:150 + source_c/d2.c:135 + source_c/d2.c:136 + source_c/d2.c:137 + source_c/d2.c:138 + source_c/d2.c:185 + source_c/d2.c:364 + source_c/d2.c:365 + source_c/d2.c:372 + source_c/d2.c:373 + source_c/d2.c:374 + source_c/d2.c:376 + source_c/d2.c:377 + source_c/d2.c:378 + source_c/av-d2.c:94 + source_c/av-d2.c:95 + source_c/lyap_spec.c:197 + source_c/lyap_spec.c:291 + source_c/lyap_spec.c:292 + source_c/lyap_spec.c:294 + source_c/lyap_spec.c:329 + source_c/lyap_spec.c:331 + source_c/lyap_spec.c:407 + source_c/lyap_spec.c:408 + source_c/lyap_spec.c:409 + source_c/lyap_spec.c:410 + source_c/lyap_spec.c:411 + source_c/lyap_spec.c:422 + source_c/lyap_spec.c:437 + source_c/lyap_spec.c:439 + source_c/lyap_spec.c:441 + source_c/lyap_spec.c:442 + source_c/lyap_spec.c:444 + source_c/lyap_spec.c:446 + source_c/lyap_spec.c:447 + source_c/lyap_spec.c:448 + source_c/lyap_spec.c:449 + source_c/lyap_spec.c:451 + source_c/lyap_spec.c:453 + source_c/lyap_spec.c:454 + source_c/lyap_spec.c:456 + source_c/lyap_spec.c:484 + source_c/nstep.c:162 + source_c/nstep.c:324 + source_c/nstep.c:325 + source_c/nstep.c:334 + source_c/nstep.c:336 + source_c/nstep.c:337 + source_c/nstep.c:339 + source_c/nstep.c:340 + source_c/nstep.c:341 + source_c/nstep.c:343 + source_c/nstep.c:345 + source_c/nstep.c:346 + source_c/nstep.c:347 + source_c/nstep.c:348 + source_c/nstep.c:350 + source_c/xzero.c:163 + source_c/xzero.c:164 + source_c/xzero.c:165 + source_c/xzero.c:166 + source_c/xzero.c:167 + source_c/xzero.c:172 + source_c/ar-model.c:142 + source_c/ar-model.c:157 + source_c/ar-model.c:181 + source_c/ar-model.c:183 + source_c/ar-model.c:262 + source_c/ar-model.c:271 + source_c/ar-model.c:272 + source_c/ar-model.c:274 + source_c/ar-model.c:276 + source_c/ar-model.c:283 + source_c/ar-model.c:285 + source_c/histogram.c:111 + source_c/zeroth.c:187 + source_c/zeroth.c:188 + source_c/zeroth.c:189 + source_c/zeroth.c:190 + source_c/zeroth.c:199 + source_c/zeroth.c:200 + source_c/zeroth.c:201 + source_c/zeroth.c:202 + source_c/zeroth.c:203 + source_c/zeroth.c:204 + source_c/zeroth.c:205 + source_c/zeroth.c:207 + source_c/zeroth.c:208 + source_c/zeroth.c:214 + source_c/polynom.c:127 + source_c/polynom.c:128 + source_c/polynom.c:130 + source_c/polynom.c:264 + source_c/polynom.c:268 + source_c/polynom.c:271 + source_c/polynomp.c:97 + source_c/polynomp.c:98 + source_c/polynomp.c:100 + source_c/polynomp.c:225 + source_c/polynomp.c:227 + source_c/polynomp.c:240 + source_c/delay.c:108 + source_c/delay.c:154 + source_c/delay.c:225 + source_c/delay.c:239 + source_c/resample.c:105 + source_c/resample.c:107 + source_c/resample.c:108 + source_c/resample.c:109 + source_c/makenoise.c:176 + source_c/makenoise.c:178 + source_c/makenoise.c:184 + source_c/boxcount.c:94 + source_c/boxcount.c:96 + source_c/boxcount.c:116 + source_c/boxcount.c:117 + source_c/boxcount.c:165 + source_c/boxcount.c:166 + source_c/boxcount.c:270 + source_c/boxcount.c:271 + source_c/boxcount.c:272 + source_c/boxcount.c:275 + source_c/arima-model.c:110 + source_c/arima-model.c:113 + source_c/arima-model.c:128 + source_c/arima-model.c:131 + source_c/arima-model.c:203 + source_c/arima-model.c:218 + source_c/arima-model.c:246 + source_c/arima-model.c:248 + source_c/arima-model.c:290 + source_c/arima-model.c:292 + source_c/arima-model.c:381 + source_c/arima-model.c:401 + source_c/arima-model.c:402 + source_c/arima-model.c:404 + source_c/arima-model.c:406 + source_c/arima-model.c:413 + source_c/arima-model.c:415 + source_c/arima-model.c:437 + source_c/arima-model.c:439 + source_c/arima-model.c:445 + source_c/arima-model.c:447 + source_c/arima-model.c:448 + source_c/arima-model.c:462 + source_c/arima-model.c:463 + source_c/arima-model.c:465 + source_c/arima-model.c:467 + source_c/routines/get_multi_series.c:49 + source_c/routines/get_multi_series.c:80 + source_c/routines/get_multi_series.c:90 + source_c/routines/get_multi_series.c:92 + source_c/routines/rand.c:45 + source_c/routines/rand.c:46 + source_c/routines/rand.c:47 + source_c/routines/rand.c:48 + source_c/routines/get_series.c:28 + source_c/routines/invert_matrix.c:17 + source_c/routines/invert_matrix.c:19 + source_c/routines/invert_matrix.c:22 + source_c/routines/invert_matrix.c:24 + source_c/routines/invert_matrix.c:27 + source_c/routines/make_multi_index.c:21 + source_c/routines/make_multi_index.c:23 + unsupported/histogram_tisean2.1.c:157 + unsupported/histogram_tisean2.1.c:158 + unsupported/rank.c:26 + unsupported/rank.c:127 + unsupported/svd.c:99 + unsupported/svd.c:100 + unsupported/svd.c:101 + unsupported/svd.c:102 + unsupported/svd.c:103 + unsupported/svd.c:105 + unsupported/clean.c:15 + unsupported/clean.c:17 + unsupported/clean.c:45 + unsupported/clean.c:56 + unsupported/clean.c:57 + unsupported/clean.c:92 + unsupported/dft.c:22 + unsupported/dft.c:53 + unsupported/dft.c:84 + unsupported/dft.c:108 + unsupported/surro.c:40 + unsupported/surro.c:41 + unsupported/surro.c:42 + unsupported/noise.c:87 + unsupported/d2.c:115 + unsupported/d2.c:116 + unsupported/d2.c:117 + unsupported/d2.c:118 + unsupported/d2.c:164 + unsupported/d2.c:296 + unsupported/d2.c:297 + unsupported/d2.c:298 + unsupported/d2.c:299 + unsupported/d2.c:300 + unsupported/d2.c:302 + unsupported/d2.c:303 + unsupported/d2.c:304 + unsupported/make_ps.cc:128 + unsupported/make_ps.cc:129 + unsupported/make_ps.cc:130 + unsupported/rand.c:37 + unsupported/rand.c:38 + unsupported/rand.c:39 + unsupported/rand.c:40 + unsupported/rand.c:41 + unsupported/surrogates.c:91 + unsupported/surrogates.c:92 + unsupported/surrogates.c:93 +autoscan: warning: missing AC_FUNC_REALLOC wanted by: + source_c/av-d2.c:134 + source_c/av-d2.c:135 + source_c/boxcount.c:128 + source_c/boxcount.c:177 + source_c/routines/get_multi_series.c:106 + source_c/routines/get_multi_series.c:129 + source_c/routines/get_multi_series.c:167 + source_c/routines/myfgets.c:22 + source_c/routines/get_series.c:41 + source_c/routines/get_series.c:63 + source_c/routines/get_series.c:87 + unsupported/eigen.c:164 + unsupported/eigen.c:165 + unsupported/clean.c:91 + unsupported/noise.c:93 + unsupported/noise.c:94 + unsupported/timerev.c:79 + unsupported/autocor3.c:86 + unsupported/surrogates.c:83 +autoscan: warning: missing AC_PREREQ wanted by: + autoscan +autoscan: warning: missing AC_PROG_CXX wanted by: + bins.sh:10 + bins.sh:13 + bins.sh:15 + bins.sh:26 + bins.sh:29 + bins.sh:37 + bins.sh:40 + unsupported/delay.cc + unsupported/histogram.cc + unsupported/lyap_k.cc + unsupported/make_ps.cc diff --git a/binaries/src/disembl/Tisean_3.0.1/bins.sh b/binaries/src/disembl/Tisean_3.0.1/bins.sh new file mode 100644 index 0000000..797c772 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/bins.sh @@ -0,0 +1,64 @@ +#! /bin/csh -f + +echo "This directory contains binary executables" >& RTMP + +switch ($OSTYPE) + +case linux: + echo "making statically linked ELF excutables for linux" + echo "meant for the LINUX operating system\n" >& RTMP + setenv CC "gcc -static -O" + setenv FC "g77 -static -O" + setenv OS "linux" + echo "C compiler used: " $CC >>& RTMP + echo "version:" >>& RTMP + $CC -v >>& RTMP + echo "" >>& RTMP + echo "Fortran compiler used: " $FC >>& RTMP + echo "version:" >>& RTMP + $FC -v >>& RTMP + echo "" >>& RTMP + breaksw + +case osf1: + echo "making statically linked excutables for osf1" + echo "meant for compaq/digital operating systems\n" >& RTMP + setenv CC "cc -non_shared -O" + setenv FC "f77 -non_shared -O" + setenv OS "osf1" + echo "C compiler used: " $CC >>& RTMP + echo "Fortran compiler used: " $FC >>& RTMP + echo "" >>& RTMP + breaksw + +case solaris: + echo "making statically linked ELF excutables for solaris" + echo "meant for solaris/SPARC operating systems\n" >& RTMP + setenv CC "cc -non_shared -O" + setenv FC "g77 -static -O" + setenv OS "osf1-g77" + echo "C compiler used: " $CC >>& RTMP + echo "Fortran compiler used: " $FC >>& RTMP + echo "version:" >>& RTMP + g77 -v >>& RTMP + echo "" >>& RTMP + breaksw + +default: + echo "cannot make " $OSTYPE " executables" + exit + breaksw + +endsw + +make mproper +./configure --prefix={$PWD}/bin-{$OS} +make install + +file bin-{$OS}/delay && \ + (echo "The executables are in the following format:" >>& RTMP) +file bin-{$OS}/delay | sed "s/.*://" >>& RTMP +mv RTMP bin-{$OS}/README +tar -vcf `basename $PWD`-{$OS}.tar bin-{$OS} +gzip -vf `basename $PWD`-{$OS}.tar +#rm -Rf bin-{$OS} diff --git a/binaries/src/disembl/Tisean_3.0.1/configure b/binaries/src/disembl/Tisean_3.0.1/configure new file mode 100644 index 0000000..c27cf28 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/configure @@ -0,0 +1,1645 @@ +#! /bin/sh + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.13 +# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. + +# Defaults: +ac_help= +ac_default_prefix=/usr/local +# Any additions from configure.in: +ac_default_prefix=${HOME} + +# Initialize some variables set by options. +# The variables have the same names as the options, with +# dashes changed to underlines. +build=NONE +cache_file=./config.cache +exec_prefix=NONE +host=NONE +no_create= +nonopt=NONE +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +target=NONE +verbose= +x_includes=NONE +x_libraries=NONE +bindir='bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datadir='${prefix}/share' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +libdir='${exec_prefix}/lib' +includedir='${prefix}/include' +oldincludedir='/usr/include' +infodir='${prefix}/info' +mandir='${prefix}/man' + +# Initialize some other variables. +subdirs= +MFLAGS= MAKEFLAGS= +SHELL=${CONFIG_SHELL-/bin/sh} +# Maximum number of lines to put in a shell here document. +ac_max_here_lines=12 + +ac_prev= +for ac_option +do + + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval "$ac_prev=\$ac_option" + ac_prev= + continue + fi + + case "$ac_option" in + -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; + *) ac_optarg= ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case "$ac_option" in + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir="$ac_optarg" ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build="$ac_optarg" ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file="$ac_optarg" ;; + + -datadir | --datadir | --datadi | --datad | --data | --dat | --da) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ + | --da=*) + datadir="$ac_optarg" ;; + + -disable-* | --disable-*) + ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + eval "enable_${ac_feature}=no" ;; + + -enable-* | --enable-*) + ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "enable_${ac_feature}='$ac_optarg'" ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix="$ac_optarg" ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he) + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat << EOF +Usage: configure [options] [host] +Options: [defaults in brackets after descriptions] +Configuration: + --cache-file=FILE cache test results in FILE + --help print this message + --no-create do not create output files + --quiet, --silent do not print \`checking...' messages + --version print the version of autoconf that created configure +Directory and file names: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [same as prefix] + --bindir=DIR user executables in DIR [EPREFIX/bin] + --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] + --libexecdir=DIR program executables in DIR [EPREFIX/libexec] + --datadir=DIR read-only architecture-independent data in DIR + [PREFIX/share] + --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data in DIR + [PREFIX/com] + --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] + --libdir=DIR object code libraries in DIR [EPREFIX/lib] + --includedir=DIR C header files in DIR [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] + --infodir=DIR info documentation in DIR [PREFIX/info] + --mandir=DIR man documentation in DIR [PREFIX/man] + --srcdir=DIR find the sources in DIR [configure dir or ..] + --program-prefix=PREFIX prepend PREFIX to installed program names + --program-suffix=SUFFIX append SUFFIX to installed program names + --program-transform-name=PROGRAM + run sed PROGRAM on installed program names +EOF + cat << EOF +Host type: + --build=BUILD configure for building on BUILD [BUILD=HOST] + --host=HOST configure for HOST [guessed] + --target=TARGET configure for TARGET [TARGET=HOST] +Features and packages: + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --x-includes=DIR X include files are in DIR + --x-libraries=DIR X library files are in DIR +EOF + if test -n "$ac_help"; then + echo "--enable and --with options recognized:$ac_help" + fi + exit 0 ;; + + -host | --host | --hos | --ho) + ac_prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + host="$ac_optarg" ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir="$ac_optarg" ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir="$ac_optarg" ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir="$ac_optarg" ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir="$ac_optarg" ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst \ + | --locals | --local | --loca | --loc | --lo) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* \ + | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) + localstatedir="$ac_optarg" ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir="$ac_optarg" ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir="$ac_optarg" ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix="$ac_optarg" ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix="$ac_optarg" ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix="$ac_optarg" ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name="$ac_optarg" ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir="$ac_optarg" ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir="$ac_optarg" ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site="$ac_optarg" ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir="$ac_optarg" ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir="$ac_optarg" ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target="$ac_optarg" ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers) + echo "configure generated by autoconf version 2.13" + exit 0 ;; + + -with-* | --with-*) + ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "with_${ac_package}='$ac_optarg'" ;; + + -without-* | --without-*) + ac_package=`echo $ac_option|sed -e 's/-*without-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + eval "with_${ac_package}=no" ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes="$ac_optarg" ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries="$ac_optarg" ;; + + -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } + ;; + + *) + if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then + echo "configure: warning: $ac_option: invalid host type" 1>&2 + fi + if test "x$nonopt" != xNONE; then + { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } + fi + nonopt="$ac_option" + ;; + + esac +done + +if test -n "$ac_prev"; then + { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } +fi + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +# File descriptor usage: +# 0 standard input +# 1 file creation +# 2 errors and warnings +# 3 some systems may open it to /dev/tty +# 4 used on the Kubota Titan +# 6 checking for... messages and results +# 5 compiler messages saved in config.log +if test "$silent" = yes; then + exec 6>/dev/null +else + exec 6>&1 +fi +exec 5>./config.log + +echo "\ +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. +" 1>&5 + +# Strip out --no-create and --no-recursion so they do not pile up. +# Also quote any args containing shell metacharacters. +ac_configure_args= +for ac_arg +do + case "$ac_arg" in + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) ;; + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) + ac_configure_args="$ac_configure_args '$ac_arg'" ;; + *) ac_configure_args="$ac_configure_args $ac_arg" ;; + esac +done + +# NLS nuisances. +# Only set these to C if already set. These must not be set unconditionally +# because not all systems understand e.g. LANG=C (notably SCO). +# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! +# Non-C LC_CTYPE values break the ctype check. +if test "${LANG+set}" = set; then LANG=C; export LANG; fi +if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi +if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi +if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo > confdefs.h + +# A filename unique to this package, relative to the directory that +# configure is in, which we can look for to find out if srcdir is correct. +ac_unique_file=source_f/readfile.f + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then its parent. + ac_prog=$0 + ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` + test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. + srcdir=$ac_confdir + if test ! -r $srcdir/$ac_unique_file; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } + else + { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } + fi +fi +srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` + +# Prefer explicitly selected file to automatically selected ones. +if test -z "$CONFIG_SITE"; then + if test "x$prefix" != xNONE; then + CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" + else + CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" + fi +fi +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + echo "loading site script $ac_site_file" + . "$ac_site_file" + fi +done + +if test -r "$cache_file"; then + echo "loading cache $cache_file" + . $cache_file +else + echo "creating cache $cache_file" + > $cache_file +fi + +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +ac_exeext= +ac_objext=o +if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then + # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. + if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then + ac_n= ac_c=' +' ac_t=' ' + else + ac_n=-n ac_c= ac_t= + fi +else + ac_n= ac_c='\c' ac_t= +fi + + + + + +test "x$prefix" = xNONE && prefix=$ac_default_prefix + +echo $ac_n "checking whether $prefix is a directory and writeable""... $ac_c" 1>&6 +echo "configure:532: checking whether $prefix is a directory and writeable" >&5 +mkdir -p $prefix 2>&5 +if test -d $prefix && echo "" > $prefix/test_conf_write \ + && rm -f $prefix/test_conf_write; then + echo "$ac_t""yes" 1>&6 +else + echo "$ac_t""no" 1>&6 + echo "configure: warning: +*** $prefix must be a writeable directory for installation +*** either you provide that or give another one, say mydir, by calling +*** $ ./configure --prefix=mydir +" 1>&2 +fi + + +for ccc in "$CC" cc gcc acc "cc -Aa"; do + if test -z "$ccc"; then + continue + fi + CC=$ccc + echo $ac_n "checking whether ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 +echo "configure:553: checking whether ($CC $CFLAGS $LDFLAGS) works" >&5 + ac_cpp='$CPP $CPPFLAGS' + ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.c 1>&5' + ac_link='$CC -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.c $LIBS 1>&5' + echo '#include "confdefs.h"' > conftest.c + echo 'main(int argc,char **argv){return(0);}' >> conftest.c + if { (eval $ac_link) 2>&5; } && test -s conftest; then + rm -fr conftest* + echo "$ac_t""yes" 1>&6 + break + else + rm -fr conftest* + echo "$ac_t""no" 1>&6 + CC= + fi +done + +if test -z "$CC"; then + echo "configure: warning: +*** No valid ANSI C compiler found +*** You will not be able to use some of the routines +*** If you do have a C compiler called by, say, mycc -ANSI, do: +*** $ setenv CC "mycc -ANSI" +*** and rerun +" 1>&2 +fi + +if test -n "$CC" && test -z "$CFLAGS"; then + echo 'void f(){}' > conftest.c + for cflags in -O3 -O2 -O +O3 +O -xO3; do + echo $ac_n "checking whether $CC accepts $cflags""... $ac_c" 1>&6 +echo "configure:584: checking whether $CC accepts $cflags" >&5 + if test -z "`$CC $cflags -c conftest.c 2>&1`"; then + echo "$ac_t""yes" 1>&6 + CFLAGS=$cflags + break + else + echo "$ac_t""no" 1>&6 + fi + done + if test -z "$CFLAGS"; then + echo "configure: warning: +*** no valid optimisation flags for $CC found +" 1>&2 + fi + rm -f conftest* +fi + +if test -n "$CC"; then + echo $ac_n "checking for main in -lm""... $ac_c" 1>&6 +echo "configure:603: checking for main in -lm" >&5 +ac_lib_var=`echo m'_'main | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lm $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + ac_tr_lib=HAVE_LIB`echo m | sed -e 's/[^a-zA-Z0-9_]/_/g' \ + -e 'y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/'` + cat >> confdefs.h <&6 +fi + + + echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 +echo "configure:647: checking how to run the C preprocessor" >&5 +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then +if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + # This must be in double quotes, not single quotes, because CPP may get + # substituted into the Makefile and "${CC-cc}" will confuse make. + CPP="${CC-cc} -E" + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. + cat > conftest.$ac_ext < +Syntax Error +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:668: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + CPP="${CC-cc} -E -traditional-cpp" + cat > conftest.$ac_ext < +Syntax Error +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:685: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + CPP="${CC-cc} -nologo -E" + cat > conftest.$ac_ext < +Syntax Error +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:702: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + CPP=/lib/cpp +fi +rm -f conftest* +fi +rm -f conftest* +fi +rm -f conftest* + ac_cv_prog_CPP="$CPP" +fi + CPP="$ac_cv_prog_CPP" +else + ac_cv_prog_CPP="$CPP" +fi +echo "$ac_t""$CPP" 1>&6 + +echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 +echo "configure:727: checking for ANSI C header files" >&5 +if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include +#include +#include +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:740: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + rm -rf conftest* + ac_cv_header_stdc=yes +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +if test $ac_cv_header_stdc = yes; then + # SunOS 4.x string.h does not declare mem*, contrary to ANSI. +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "memchr" >/dev/null 2>&1; then + : +else + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "free" >/dev/null 2>&1; then + : +else + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. +if test "$cross_compiling" = yes; then + : +else + cat > conftest.$ac_ext < +#define ISLOWER(c) ('a' <= (c) && (c) <= 'z') +#define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) +#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) +int main () { int i; for (i = 0; i < 256; i++) +if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); +exit (0); } + +EOF +if { (eval echo configure:807: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +then + : +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -fr conftest* + ac_cv_header_stdc=no +fi +rm -fr conftest* +fi + +fi +fi + +echo "$ac_t""$ac_cv_header_stdc" 1>&6 +if test $ac_cv_header_stdc = yes; then + cat >> confdefs.h <<\EOF +#define STDC_HEADERS 1 +EOF + +fi + + for ac_hdr in limits.h malloc.h +do +ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` +echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 +echo "configure:834: checking for $ac_hdr" >&5 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:844: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'` + cat >> confdefs.h <&6 +fi +done + + + echo $ac_n "checking for working const""... $ac_c" 1>&6 +echo "configure:872: checking for working const" >&5 +if eval "test \"`echo '$''{'ac_cv_c_const'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext <j = 5; +} +{ /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */ + const int foo = 10; +} + +; return 0; } +EOF +if { (eval echo configure:926: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_c_const=yes +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + ac_cv_c_const=no +fi +rm -f conftest* +fi + +echo "$ac_t""$ac_cv_c_const" 1>&6 +if test $ac_cv_c_const = no; then + cat >> confdefs.h <<\EOF +#define const +EOF + +fi + + if test $ac_cv_c_const = no; then + CC="$CC -Dconst=" + fi + + echo $ac_n "checking for size_t""... $ac_c" 1>&6 +echo "configure:951: checking for size_t" >&5 +if eval "test \"`echo '$''{'ac_cv_type_size_t'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#if STDC_HEADERS +#include +#include +#endif +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "(^|[^a-zA-Z_0-9])size_t[^a-zA-Z_0-9]" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_size_t=yes +else + rm -rf conftest* + ac_cv_type_size_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_size_t" 1>&6 +if test $ac_cv_type_size_t = no; then + cat >> confdefs.h <<\EOF +#define size_t unsigned +EOF + +fi + + + echo $ac_n "checking for 8-bit clean memcmp""... $ac_c" 1>&6 +echo "configure:985: checking for 8-bit clean memcmp" >&5 +if eval "test \"`echo '$''{'ac_cv_func_memcmp_clean'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test "$cross_compiling" = yes; then + ac_cv_func_memcmp_clean=no +else + cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +then + ac_cv_func_memcmp_clean=yes +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -fr conftest* + ac_cv_func_memcmp_clean=no +fi +rm -fr conftest* +fi + +fi + +echo "$ac_t""$ac_cv_func_memcmp_clean" 1>&6 +test $ac_cv_func_memcmp_clean = no && LIBOBJS="$LIBOBJS memcmp.${ac_objext}" + +fi + + + +for fff in "$FC" f77 g77 "f77 +U77" "f77 -q -f -B108 -lU77"; do + if test -z "$fff"; then + continue + fi + FC=$fff + echo $ac_n "checking whether ($FC $FFLAGS $LDFLAGS) works""... $ac_c" 1>&6 +echo "configure:1030: checking whether ($FC $FFLAGS $LDFLAGS) works" >&5 + cat > conftest.f << EOF + character*20 argv + call getarg(1,argv) + write(*,'(2hxx,a)') argv + end +EOF + (eval $FC $FFLAGS $LDFLAGS conftest.f -o conftest) 1>&5 2>&5 + if test -n "`(eval ./conftest TEST | grep xxTEST) 2>&5`"; then + rm -f conftest.f conftest + echo "$ac_t""yes" 1>&6 + break + else + rm -f conftest.f conftest + echo "$ac_t""no" 1>&6 + FC= + fi +done + +if test -z "$FC"; then + echo "configure: warning: +*** No usable Fortran compiler found +*** You will not be able to use some of the routines +*** If you do have a working Fortran compiler called, say, myf77 -trick, do: +*** $ setenv FC "myf77 -trick" +*** and rerun +" 1>&2 +fi + +if test -z "$CC" && test -z "$FC"; then + { echo "configure: error: +*** with neither working C nor Fortran compilers there wouldn't be any +*** programs left you could compile +" 1>&2; exit 1; } +fi + +if test -n "$FC" && test -z "$FFLAGS"; then + echo ' end' > conftest.f + for fflags in -O +O; do + echo $ac_n "checking whether $FC accepts $fflags""... $ac_c" 1>&6 +echo "configure:1070: checking whether $FC accepts $fflags" >&5 + cat > conftest.f << EOF + write(*,'(6hxxTEST)') + end +EOF + (eval $FC $fflags $LDFLAGS conftest.f -o conftest) 1>&5 2>&5 + if test -n "`(eval ./conftest | grep xxTEST) 2>&5`"; then + rm -f conftest.f conftest + echo "$ac_t""yes" 1>&6 + FFLAGS=$fflags + break + else + rm -f conftest.f conftest + echo "$ac_t""no" 1>&6 + fi + done + if test -z "$FFLAGS"; then + echo "configure: warning: +*** no valid optimisation flags for $FC found +" 1>&2 + fi + rm -f conftest* +fi + + + + +if test -n "$FC"; then + ERRUNIT="" + for iu in 0 1 2 3 4 6 7 8 9; do + echo $ac_n "checking whether Fortran unit $iu is stderr""... $ac_c" 1>&6 +echo "configure:1101: checking whether Fortran unit $iu is stderr" >&5 + rm -Rf ./config_test_dir + mkdir ./config_test_dir + cd ./config_test_dir + echo " write($iu,'(1ht)')" > test.f + echo " end" >> test.f + (eval $FC $FFLAGS test.f -o test.out) 1>&5 2>&5 + if test -z "`./test.out 2>&1 1>/dev/null`"; then + cd .. + rm -Rf ./config_test_dir + echo "$ac_t""no" 1>&6 + else + cd .. + rm -Rf ./config_test_dir + echo "$ac_t""yes" 1>&6 + ERRUNIT=$iu + break + fi + done + if test -z $ERRUNIT; then + ERRUNIT=0 + echo "configure: warning: +*** Couldn't determine Fortran stderr unit, assuming unit 0, fingers crossed +" 1>&2 + fi + +fi + +# Extract the first word of "ar", so it can be a program name with args. +set dummy ar; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:1132: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_AR'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$AR"; then + ac_cv_prog_AR="$AR" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_AR="ar" + break + fi + done + IFS="$ac_save_ifs" + test -z "$ac_cv_prog_AR" && ac_cv_prog_AR="ar" +fi +fi +AR="$ac_cv_prog_AR" +if test -n "$AR"; then + echo "$ac_t""$AR" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + +ARFLAGS=r +echo $ac_n "checking whether ${AR} accepts ${ARFLAGS}""... $ac_c" 1>&6 +echo "configure:1161: checking whether ${AR} accepts ${ARFLAGS}" >&5 +if test -n "$CC"; then + echo 'void f(){}' > libtest.c + ${CC} -c libtest.c +else + echo ' end' > libtest.f + ${FC} -c libtest.f +fi +${AR} ${ARFLAGS} libtest.a libtest.o 1>&5 2>&5 +if test -s libtest.a; then + echo "$ac_t""yes" 1>&6 +else + ARFLAGS=-r + echo "$ac_t""no, using ${ARFLAGS} instead" 1>&6 +fi +rm -f libtest.* + + +ac_aux_dir= +for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do + if test -f $ac_dir/install-sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f $ac_dir/install.sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + fi +done +if test -z "$ac_aux_dir"; then + { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; } +fi +ac_config_guess=$ac_aux_dir/config.guess +ac_config_sub=$ac_aux_dir/config.sub +ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. + +# Find a good install program. We prefer a C program (faster), +# so one script is as good as another. But avoid the broken or +# incompatible versions: +# SysV /etc/install, /usr/sbin/install +# SunOS /usr/etc/install +# IRIX /sbin/install +# AIX /bin/install +# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag +# AFS /usr/afsws/bin/install, which mishandles nonexistent args +# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" +# ./install, which can be erroneously created by make from ./install.sh. +echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 +echo "configure:1210: checking for a BSD compatible install" >&5 +if test -z "$INSTALL"; then +if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS=":" + for ac_dir in $PATH; do + # Account for people who put trailing slashes in PATH elements. + case "$ac_dir/" in + /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;; + *) + # OSF1 and SCO ODT 3.0 have their own names for install. + # Don't use installbsd from OSF since it installs stuff as root + # by default. + for ac_prog in ginstall scoinst install; do + if test -f $ac_dir/$ac_prog; then + if test $ac_prog = install && + grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then + # AIX install. It has an incompatible calling convention. + : + else + ac_cv_path_install="$ac_dir/$ac_prog -c" + break 2 + fi + fi + done + ;; + esac + done + IFS="$ac_save_IFS" + +fi + if test "${ac_cv_path_install+set}" = set; then + INSTALL="$ac_cv_path_install" + else + # As a last resort, use the slow shell script. We don't cache a + # path for INSTALL within a source directory, because that will + # break other packages using the cache if that directory is + # removed, or if the path is relative. + INSTALL="$ac_install_sh" + fi +fi +echo "$ac_t""$INSTALL" 1>&6 + +# Use test -z because SunOS4 sh mishandles braces in ${var-val}. +# It thinks the first close brace ends the variable substitution. +test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' + +test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' + +test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' + +echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 +echo "configure:1263: checking whether ${MAKE-make} sets \${MAKE}" >&5 +set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftestmake <<\EOF +all: + @echo 'ac_maketemp="${MAKE}"' +EOF +# GNU make sometimes prints "make[1]: Entering...", which would confuse us. +eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=` +if test -n "$ac_maketemp"; then + eval ac_cv_prog_make_${ac_make}_set=yes +else + eval ac_cv_prog_make_${ac_make}_set=no +fi +rm -f conftestmake +fi +if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then + echo "$ac_t""yes" 1>&6 + SET_MAKE= +else + echo "$ac_t""no" 1>&6 + SET_MAKE="MAKE=${MAKE-make}" +fi + +# Extract the first word of "ranlib", so it can be a program name with args. +set dummy ranlib; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:1292: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$RANLIB"; then + ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_RANLIB="ranlib" + break + fi + done + IFS="$ac_save_ifs" + test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":" +fi +fi +RANLIB="$ac_cv_prog_RANLIB" +if test -n "$RANLIB"; then + echo "$ac_t""$RANLIB" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + +for ac_prog in gnuplot +do +# Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:1325: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_GP'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$GP"; then + ac_cv_prog_GP="$GP" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" + ac_dummy="$PATH" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_GP="$ac_prog" + break + fi + done + IFS="$ac_save_ifs" +fi +fi +GP="$ac_cv_prog_GP" +if test -n "$GP"; then + echo "$ac_t""$GP" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + +test -n "$GP" && break +done + +if test -n "$GP"; then + echo $ac_n "checking if gnuplot can read from a pipe""... $ac_c" 1>&6 +echo "configure:1356: checking if gnuplot can read from a pipe" >&5 + cat > conftest.gnu <&5 1>&5; then + rm -f conftest.gnu + echo "$ac_t""yes +:-) you may try to run $GP on the following files + after you installed everything:" 1>&6 + find examples -name "*.gnu" -print | sed "s%\./% %" + echo "" + else + rm -f conftest.gnu + echo "$ac_t""no +:-( you may not be able to run $GP on the examples + docs_f/docs/*.gnu without changes" 1>&6 + fi +fi + +trap '' 1 2 15 +cat > confcache <<\EOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs. It is not useful on other systems. +# If it contains results you don't want to keep, you may remove or edit it. +# +# By default, configure uses ./config.cache as the cache file, +# creating it if it does not exist already. You can give configure +# the --cache-file=FILE option to use a different cache file; that is +# what configure does when it calls configure scripts in +# subdirectories, so they share the cache. +# Giving --cache-file=/dev/null disables caching, for debugging configure. +# config.status only pays attention to the cache file if you give it the +# --recheck option to rerun configure. +# +EOF +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, don't put newlines in cache variables' values. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +(set) 2>&1 | + case `(ac_space=' '; set | grep ac_space) 2>&1` in + *ac_space=\ *) + # `set' does not quote correctly, so add quotes (double-quote substitution + # turns \\\\ into \\, and sed turns \\ into \). + sed -n \ + -e "s/'/'\\\\''/g" \ + -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" + ;; + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' + ;; + esac >> confcache +if cmp -s $cache_file confcache; then + : +else + if test -w $cache_file; then + echo "updating cache $cache_file" + cat confcache > $cache_file + else + echo "not updating unwritable cache $cache_file" + fi +fi +rm -f confcache + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Any assignment to VPATH causes Sun make to only execute +# the first set of double-colon rules, so remove it if not needed. +# If there is a colon in the path, we need to keep it. +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' +fi + +trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 + +# Transform confdefs.h into DEFS. +# Protect against shell expansion while executing Makefile rules. +# Protect against Makefile macro expansion. +cat > conftest.defs <<\EOF +s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g +s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g +s%\[%\\&%g +s%\]%\\&%g +s%\$%$$%g +EOF +DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` +rm -f conftest.defs + + +# Without the "./", some shells look in PATH for config.status. +: ${CONFIG_STATUS=./config.status} + +echo creating $CONFIG_STATUS +rm -f $CONFIG_STATUS +cat > $CONFIG_STATUS </dev/null | sed 1q`: +# +# $0 $ac_configure_args +# +# Compiler output produced by configure, useful for debugging +# configure, is in ./config.log if it exists. + +ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" +for ac_option +do + case "\$ac_option" in + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" + exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; + -version | --version | --versio | --versi | --vers | --ver | --ve | --v) + echo "$CONFIG_STATUS generated by autoconf version 2.13" + exit 0 ;; + -help | --help | --hel | --he | --h) + echo "\$ac_cs_usage"; exit 0 ;; + *) echo "\$ac_cs_usage"; exit 1 ;; + esac +done + +ac_given_srcdir=$srcdir +ac_given_INSTALL="$INSTALL" + +trap 'rm -fr `echo "Makefile source_f/Makefile source_f/slatec/Makefile source_f/randomize/Makefile source_c/Makefile source_c/routines/Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 +EOF +cat >> $CONFIG_STATUS < conftest.subs <<\\CEOF +$ac_vpsub +$extrasub +s%@SHELL@%$SHELL%g +s%@CFLAGS@%$CFLAGS%g +s%@CPPFLAGS@%$CPPFLAGS%g +s%@CXXFLAGS@%$CXXFLAGS%g +s%@FFLAGS@%$FFLAGS%g +s%@DEFS@%$DEFS%g +s%@LDFLAGS@%$LDFLAGS%g +s%@LIBS@%$LIBS%g +s%@exec_prefix@%$exec_prefix%g +s%@prefix@%$prefix%g +s%@program_transform_name@%$program_transform_name%g +s%@bindir@%$bindir%g +s%@sbindir@%$sbindir%g +s%@libexecdir@%$libexecdir%g +s%@datadir@%$datadir%g +s%@sysconfdir@%$sysconfdir%g +s%@sharedstatedir@%$sharedstatedir%g +s%@localstatedir@%$localstatedir%g +s%@libdir@%$libdir%g +s%@includedir@%$includedir%g +s%@oldincludedir@%$oldincludedir%g +s%@infodir@%$infodir%g +s%@mandir@%$mandir%g +s%@CPP@%$CPP%g +s%@LIBOBJS@%$LIBOBJS%g +s%@CC@%$CC%g +s%@FC@%$FC%g +s%@ERRUNIT@%$ERRUNIT%g +s%@AR@%$AR%g +s%@ARFLAGS@%$ARFLAGS%g +s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g +s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g +s%@INSTALL_DATA@%$INSTALL_DATA%g +s%@SET_MAKE@%$SET_MAKE%g +s%@RANLIB@%$RANLIB%g +s%@GP@%$GP%g + +CEOF +EOF + +cat >> $CONFIG_STATUS <<\EOF + +# Split the substitutions into bite-sized pieces for seds with +# small command number limits, like on Digital OSF/1 and HP-UX. +ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. +ac_file=1 # Number of current file. +ac_beg=1 # First line for current file. +ac_end=$ac_max_sed_cmds # Line after last line for current file. +ac_more_lines=: +ac_sed_cmds="" +while $ac_more_lines; do + if test $ac_beg -gt 1; then + sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file + else + sed "${ac_end}q" conftest.subs > conftest.s$ac_file + fi + if test ! -s conftest.s$ac_file; then + ac_more_lines=false + rm -f conftest.s$ac_file + else + if test -z "$ac_sed_cmds"; then + ac_sed_cmds="sed -f conftest.s$ac_file" + else + ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" + fi + ac_file=`expr $ac_file + 1` + ac_beg=$ac_end + ac_end=`expr $ac_end + $ac_max_sed_cmds` + fi +done +if test -z "$ac_sed_cmds"; then + ac_sed_cmds=cat +fi +EOF + +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF +for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case "$ac_file" in + *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` + ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; + *) ac_file_in="${ac_file}.in" ;; + esac + + # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. + + # Remove last slash and all that follows it. Not all systems have dirname. + ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` + if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then + # The file is in a subdirectory. + test ! -d "$ac_dir" && mkdir "$ac_dir" + ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" + # A "../" for each directory in $ac_dir_suffix. + ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` + else + ac_dir_suffix= ac_dots= + fi + + case "$ac_given_srcdir" in + .) srcdir=. + if test -z "$ac_dots"; then top_srcdir=. + else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; + /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; + *) # Relative path. + srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" + top_srcdir="$ac_dots$ac_given_srcdir" ;; + esac + + case "$ac_given_INSTALL" in + [/$]*) INSTALL="$ac_given_INSTALL" ;; + *) INSTALL="$ac_dots$ac_given_INSTALL" ;; + esac + + echo creating "$ac_file" + rm -f "$ac_file" + configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." + case "$ac_file" in + *Makefile*) ac_comsub="1i\\ +# $configure_input" ;; + *) ac_comsub= ;; + esac + + ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` + sed -e "$ac_comsub +s%@configure_input@%$configure_input%g +s%@srcdir@%$srcdir%g +s%@top_srcdir@%$top_srcdir%g +s%@INSTALL@%$INSTALL%g +" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file +fi; done +rm -f conftest.s* + +EOF +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF + +exit 0 +EOF +chmod +x $CONFIG_STATUS +rm -fr confdefs* $ac_clean_files +test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 + diff --git a/binaries/src/disembl/Tisean_3.0.1/configure.in b/binaries/src/disembl/Tisean_3.0.1/configure.in new file mode 100644 index 0000000..d55a143 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/configure.in @@ -0,0 +1,247 @@ +dnl Process this file with autoconf to produce a configure script. +AC_INIT(source_f/readfile.f) + +AC_PREFIX_DEFAULT(${HOME}) + +dnl Check for prfix directory and create it if necessary +test "x$prefix" = xNONE && prefix=$ac_default_prefix + +AC_MSG_CHECKING([whether $prefix is a directory and writeable]) +mkdir -p $prefix 2>&5 +if test -d $prefix && echo "" > $prefix/test_conf_write \ + && rm -f $prefix/test_conf_write; then + AC_MSG_RESULT(yes) +else + AC_MSG_RESULT(no) + AC_MSG_WARN([ +*** $prefix must be a writeable directory for installation +*** either you provide that or give another one, say mydir, by calling +*** $ ./configure --prefix=mydir +]) +fi + +dnl Checks for programs. + +for ccc in "$CC" cc gcc acc "cc -Aa"; do + if test -z "$ccc"; then + continue + fi + CC=$ccc + AC_MSG_CHECKING([whether ($CC $CFLAGS $LDFLAGS) works]) + ac_cpp='$CPP $CPPFLAGS' + ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.c 1>&5' + ac_link='$CC -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.c $LIBS 1>&5' + echo '#include "confdefs.h"' > conftest.c + echo 'main(int argc,char **argv){return(0);}' >> conftest.c + if { (eval $ac_link) 2>&5; } && test -s conftest; then + rm -fr conftest* + AC_MSG_RESULT(yes) + break + else + rm -fr conftest* + AC_MSG_RESULT(no) + CC= + fi +done + +if test -z "$CC"; then + AC_MSG_WARN([ +*** No valid ANSI C compiler found +*** You will not be able to use some of the routines +*** If you do have a C compiler called by, say, mycc -ANSI, do: +*** $ setenv CC "mycc -ANSI" +*** and rerun +]) +fi + +if test -n "$CC" && test -z "$CFLAGS"; then + echo 'void f(){}' > conftest.c + for cflags in -O3 -O2 -O +O3 +O -xO3; do + AC_MSG_CHECKING([whether $CC accepts $cflags]) + if test -z "`$CC $cflags -c conftest.c 2>&1`"; then + AC_MSG_RESULT(yes) + CFLAGS=$cflags + break + else + AC_MSG_RESULT(no) + fi + done + if test -z "$CFLAGS"; then + AC_MSG_WARN([ +*** no valid optimisation flags for $CC found +]) + fi + rm -f conftest* +fi + +if test -n "$CC"; then + AC_CHECK_LIB(m, main) + +dnl Checks for header files. + AC_HEADER_STDC + AC_CHECK_HEADERS(limits.h malloc.h) + +dnl Checks for typedefs, structures, and compiler characteristics. + AC_C_CONST + if test $ac_cv_c_const = no; then + CC="$CC -Dconst=" + fi + + AC_TYPE_SIZE_T + +dnl Checks for library functions. + AC_FUNC_MEMCMP +fi + +AC_SUBST(CC) + +for fff in "$FC" f77 g77 "f77 +U77" "f77 -q -f -B108 -lU77"; do + if test -z "$fff"; then + continue + fi + FC=$fff + AC_MSG_CHECKING([whether ($FC $FFLAGS $LDFLAGS) works]) + cat > conftest.f << EOF + character*20 argv + call getarg(1,argv) + write(*,'(2hxx,a)') argv + end +EOF + (eval $FC $FFLAGS $LDFLAGS conftest.f -o conftest) 1>&5 2>&5 + if test -n "`(eval ./conftest TEST | grep xxTEST) 2>&5`"; then + rm -f conftest.f conftest + AC_MSG_RESULT(yes) + break + else + rm -f conftest.f conftest + AC_MSG_RESULT(no) + FC= + fi +done + +if test -z "$FC"; then + AC_MSG_WARN([ +*** No usable Fortran compiler found +*** You will not be able to use some of the routines +*** If you do have a working Fortran compiler called, say, myf77 -trick, do: +*** $ setenv FC "myf77 -trick" +*** and rerun +]) +fi + +if test -z "$CC" && test -z "$FC"; then + AC_MSG_ERROR([ +*** with neither working C nor Fortran compilers there wouldn't be any +*** programs left you could compile +]) +fi + +if test -n "$FC" && test -z "$FFLAGS"; then + echo ' end' > conftest.f + for fflags in -O +O; do + AC_MSG_CHECKING([whether $FC accepts $fflags]) + cat > conftest.f << EOF + write(*,'(6hxxTEST)') + end +EOF + (eval $FC $fflags $LDFLAGS conftest.f -o conftest) 1>&5 2>&5 + if test -n "`(eval ./conftest | grep xxTEST) 2>&5`"; then + rm -f conftest.f conftest + AC_MSG_RESULT(yes) + FFLAGS=$fflags + break + else + rm -f conftest.f conftest + AC_MSG_RESULT(no) + fi + done + if test -z "$FFLAGS"; then + AC_MSG_WARN([ +*** no valid optimisation flags for $FC found +]) + fi + rm -f conftest* +fi + +AC_SUBST(FC) +AC_SUBST(FFLAGS) + +if test -n "$FC"; then + ERRUNIT="" + for iu in 0 1 2 3 4 6 7 8 9; do + AC_MSG_CHECKING([whether Fortran unit $iu is stderr]) + rm -Rf ./config_test_dir + mkdir ./config_test_dir + cd ./config_test_dir + echo " write($iu,'(1ht)')" > test.f + echo " end" >> test.f + (eval $FC $FFLAGS test.f -o test.out) 1>&5 2>&5 + if test -z "`./test.out 2>&1 1>/dev/null`"; then + cd .. + rm -Rf ./config_test_dir + AC_MSG_RESULT(no) + else + cd .. + rm -Rf ./config_test_dir + AC_MSG_RESULT(yes) + ERRUNIT=$iu + break + fi + done + if test -z $ERRUNIT; then + ERRUNIT=0 + AC_MSG_WARN([ +*** Couldn't determine Fortran stderr unit, assuming unit 0, fingers crossed +]) + fi + AC_SUBST(ERRUNIT) +fi + +AC_CHECK_PROG(AR,ar,ar,ar) +ARFLAGS=r +AC_MSG_CHECKING([whether ${AR} accepts ${ARFLAGS}]) +if test -n "$CC"; then + echo 'void f(){}' > libtest.c + ${CC} -c libtest.c +else + echo ' end' > libtest.f + ${FC} -c libtest.f +fi +${AR} ${ARFLAGS} libtest.a libtest.o 1>&5 2>&5 +if test -s libtest.a; then + AC_MSG_RESULT(yes) +else + ARFLAGS=-r + AC_MSG_RESULT([no, using ${ARFLAGS} instead]) +fi +rm -f libtest.* +AC_SUBST(ARFLAGS) + +AC_PROG_INSTALL +AC_PROG_MAKE_SET +AC_PROG_RANLIB + +AC_CHECK_PROGS(GP,gnuplot) +if test -n "$GP"; then + AC_MSG_CHECKING(if gnuplot can read from a pipe) + cat > conftest.gnu <&5 1>&5; then + rm -f conftest.gnu + AC_MSG_RESULT([yes +:-) you may try to run $GP on the following files + after you installed everything:]) + find examples -name "*.gnu" -print | sed "s%\./% %" + echo "" + else + rm -f conftest.gnu + AC_MSG_RESULT([no +:-( you may not be able to run $GP on the examples + docs_f/docs/*.gnu without changes]) + fi +fi + +AC_OUTPUT(Makefile source_f/Makefile source_f/slatec/Makefile source_f/randomize/Makefile source_c/Makefile source_c/routines/Makefile) diff --git a/binaries/src/disembl/Tisean_3.0.1/configure.scan b/binaries/src/disembl/Tisean_3.0.1/configure.scan new file mode 100644 index 0000000..bfa2ab9 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/configure.scan @@ -0,0 +1,41 @@ +# -*- Autoconf -*- +# Process this file with autoconf to produce a configure script. + +AC_PREREQ(2.59) +AC_INIT(FULL-PACKAGE-NAME, VERSION, BUG-REPORT-ADDRESS) +AC_CONFIG_SRCDIR([source_c/polypar.c]) +AC_CONFIG_HEADER([config.h]) + +# Checks for programs. +AC_PROG_CXX +AC_PROG_CC +AC_PROG_INSTALL +AC_PROG_MAKE_SET +AC_PROG_RANLIB + +# Checks for libraries. +# FIXME: Replace `main' with a function in `-lm': +AC_CHECK_LIB([m], [main]) + +# Checks for header files. +AC_HEADER_STDC +AC_CHECK_HEADERS([limits.h malloc.h stddef.h stdlib.h string.h]) + +# Checks for typedefs, structures, and compiler characteristics. +AC_C_CONST +AC_TYPE_SIZE_T + +# Checks for library functions. +AC_FUNC_ERROR_AT_LINE +AC_FUNC_MALLOC +AC_FUNC_MEMCMP +AC_FUNC_REALLOC +AC_CHECK_FUNCS([pow sqrt strrchr strstr]) + +AC_CONFIG_FILES([Makefile + source_c/Makefile + source_c/routines/Makefile + source_f/Makefile + source_f/randomize/Makefile + source_f/slatec/Makefile]) +AC_OUTPUT diff --git a/binaries/src/disembl/Tisean_3.0.1/index.html b/binaries/src/disembl/Tisean_3.0.1/index.html new file mode 100644 index 0000000..e5111b8 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/index.html @@ -0,0 +1,7 @@ + +Nonlinear Time Series Routines + + + + + \ No newline at end of file diff --git a/binaries/src/disembl/Tisean_3.0.1/install-sh b/binaries/src/disembl/Tisean_3.0.1/install-sh new file mode 100644 index 0000000..89fc9b0 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/install-sh @@ -0,0 +1,238 @@ +#! /bin/sh +# +# install - install a program, script, or datafile +# This comes from X11R5. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. +# + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" +mkdirprog="${MKDIRPROG-mkdir}" + +tranformbasename="" +transform_arg="" +instcmd="$mvprog" +chmodcmd="$chmodprog 0755" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" +dir_arg="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -d) dir_arg=true + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + -t=*) transformarg=`echo $1 | sed 's/-t=//'` + shift + continue;; + + -b=*) transformbasename=`echo $1 | sed 's/-b=//'` + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + # this colon is to work around a 386BSD /bin/sh bug + : + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +else + true +fi + +if [ x"$dir_arg" != x ]; then + dst=$src + src="" + + if [ -d $dst ]; then + instcmd=: + else + instcmd=mkdir + fi +else + +# Waiting for this to be detected by the "$instcmd $src $dsttmp" command +# might cause directories to be created, which would be especially bad +# if $src (and thus $dsttmp) contains '*'. + + if [ -f $src -o -d $src ] + then + true + else + echo "install: $src does not exist" + exit 1 + fi + + if [ x"$dst" = x ] + then + echo "install: no destination specified" + exit 1 + else + true + fi + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + + if [ -d $dst ] + then + dst="$dst"/`basename $src` + else + true + fi +fi + +## this sed command emulates the dirname command +dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` + +# Make sure that the destination directory exists. +# this part is taken from Noah Friedman's mkinstalldirs script + +# Skip lots of stat calls in the usual case. +if [ ! -d "$dstdir" ]; then +defaultIFS=' +' +IFS="${IFS-${defaultIFS}}" + +oIFS="${IFS}" +# Some sh's can't handle IFS=/ for some reason. +IFS='%' +set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` +IFS="${oIFS}" + +pathcomp='' + +while [ $# -ne 0 ] ; do + pathcomp="${pathcomp}${1}" + shift + + if [ ! -d "${pathcomp}" ] ; + then + $mkdirprog "${pathcomp}" + else + true + fi + + pathcomp="${pathcomp}/" +done +fi + +if [ x"$dir_arg" != x ] +then + $doit $instcmd $dst && + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi +else + +# If we're going to rename the final executable, determine the name now. + + if [ x"$transformarg" = x ] + then + dstfile=`basename $dst` + else + dstfile=`basename $dst $transformbasename | + sed $transformarg`$transformbasename + fi + +# don't allow the sed command to completely eliminate the filename + + if [ x"$dstfile" = x ] + then + dstfile=`basename $dst` + else + true + fi + +# Make a temp file name in the proper directory. + + dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + + $doit $instcmd $src $dsttmp && + + trap "rm -f ${dsttmp}" 0 && + +# and set any options; do chmod last to preserve setuid bits + +# If any of these fail, we abort the whole thing. If we want to +# ignore errors from any of these, just make sure not to ignore +# errors from the above "$doit $instcmd $src $dsttmp" command. + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && + +# Now rename the file to the real destination. + + $doit $rmcmd -f $dstdir/$dstfile && + $doit $mvcmd $dsttmp $dstdir/$dstfile + +fi && + + +exit 0 diff --git a/binaries/src/disembl/Tisean_3.0.1/logo b/binaries/src/disembl/Tisean_3.0.1/logo new file mode 100644 index 0000000..07b5d40 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/logo @@ -0,0 +1,14 @@ +_______________________________________________________________________________ + + _/_/_/_/_/ _/ _/_/_/ _/_/_/_/ _/_/ _/ _/ + _/ _/ _/ _/ _/ _/ _/ _/ _/ + _/ _/ _/ _/ _/ _/ _/_/ _/ + _/ _/ _/_/_/ _/_/_/_/ _/_/_/_/ _/ _/ _/ + _/ _/ _/ _/ _/ _/ _/ _/_/ + _/ _/ _/ _/ _/ _/ _/ _/ _/ + _/ _/ _/_/_/ _/_/_/_/ _/ _/ _/ _/ + + Nonlinear time series pproject + Copyright (C) Rainer Hegger & Thomas Schreiber (1998-2007) +_______________________________________________________________________________ + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/Makefile.in b/binaries/src/disembl/Tisean_3.0.1/source_c/Makefile.in new file mode 100644 index 0000000..1ab10e4 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/Makefile.in @@ -0,0 +1,47 @@ +SHELL = /bin/sh + +prefix = @prefix@ +exec_prefix = @exec_prefix@ +BINDIR = ${exec_prefix}/@bindir@ + +CC = @CC@ +CFLAGS = @CFLAGS@ +AR = @AR@ +ARFLAGS = @ARFLAGS@ +INSTALL = @INSTALL@ + +LOADLIBS = routines/libddtsa.a -lm + +# list of executables we want to produce + ALL = poincare extrema rescale recurr corr mutual false_nearest \ + lyap_r lyap_k lyap_spec d2 av-d2 makenoise nrlazy low121 \ + lzo-test lfo-run lfo-test rbf polynom polyback polynomp polypar \ + ar-model mem_spec pca ghkss lfo-ar xzero xcor boxcount fsle \ + resample histogram nstat_z sav_gol delay lzo-gm arima-model \ + lzo-run + +all: $(ALL) + +routines/libddtsa.a: + (cd routines && $(MAKE)) + +$(ALL): routines/libddtsa.a *.c + -$(CC) $(CFLAGS) $(COPTS) -o $@ $@.c $(LOADLIBS) + +install: all + -for bin in $(ALL); do $(INSTALL) $$bin $(BINDIR); done + +clean: + @rm -f *.o *~ #*# + @rm -f $(ALL) + -(cd routines && $(MAKE) clean) + +missing: + -@for bin in $(ALL); do \ + test -z "`$$bin -h 2>&1 | grep Usage`" \ + && echo $$bin "(Dresden C)" >> ../missing.log; \ + $$bin -h 2>&1 | cat >> ../install.log; \ + done; : + +uninstall: + -@for bin in $(ALL); do rm -f $(BINDIR)/$$bin; done diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/ar-model.c b/binaries/src/disembl/Tisean_3.0.1/source_c/ar-model.c new file mode 100644 index 0000000..5481a3b --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/ar-model.c @@ -0,0 +1,395 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger*/ +/*Changes: + Jun 24, 2005: Output average error for multivariate data + Nov 25, 2005: Handle model order = 0 + Jan 31, 2006: Add verbosity 4 to print data+residuals + */ +#include +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Fits an multivariate AR model to the data and gives\ + the coefficients\n\tand the residues (or an iterated model)" + +unsigned long length=ULONG_MAX,exclude=0; +unsigned int dim=1,poles=1,ilength; +unsigned int verbosity=1; +char *outfile=NULL,*column=NULL,stdo=1,dimset=0,run_model=0; +char *infile=NULL; +double **series,*my_average; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l length of file [default is whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default is 0]\n"); + fprintf(stderr,"\t-m dimension [default is 1]\n"); + fprintf(stderr,"\t-c columns to read [default is 1,...,dimension]\n"); + fprintf(stderr,"\t-p #order of AR-Fit [default is 1]\n"); + fprintf(stderr,"\t-s length of iterated model [default no iteration]\n"); + fprintf(stderr,"\t-o output file name [default is 'datafile'.ar]\n"); + fprintf(stderr,"\t-V verbosity level [default is 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n\t\t" + "2='+ print residuals though iterating a model'\n\t\t" + "4='+ print original data plus residuals'\n"); + fprintf(stderr,"\t-h show these options\n\n"); + exit(0); +} + +void scan_options(int argc,char **argv) +{ + char *out; + + if ((out=check_option(argv,argc,'p','u')) != NULL) { + sscanf(out,"%u",&poles); + if (poles < 1) { + fprintf(stderr,"The order should at least be one!\n"); + exit(127); + } + } + if ((out=check_option(argv,argc,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(argv,argc,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(argv,argc,'m','u')) != NULL) { + sscanf(out,"%u",&dim); + dimset=1; + } + if ((out=check_option(argv,argc,'c','u')) != NULL) + column=out; + if ((out=check_option(argv,argc,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(argv,argc,'s','u')) != NULL) { + sscanf(out,"%u",&ilength); + run_model=1; + } + if ((out=check_option(argv,argc,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void set_averages_to_zero(void) +{ + double var; + long i,j; + + for (i=0;i= length) { + fprintf(stderr,"It makes no sense to have more poles than data! Exiting\n"); + exit(AR_MODEL_TOO_MANY_POLES); + } + + + check_alloc(vec=(double*)malloc(sizeof(double)*poles*dim)); + check_alloc(mat=(double**)malloc(sizeof(double*)*poles*dim)); + for (i=0;i 0)) + iterate_model(coeff,pm,NULL); + } + else { + file=fopen(outfile,"w"); + if (verbosity&VER_INPUT) + fprintf(stderr,"Opened %s for output\n",outfile); + avpm=pm[0]*pm[0]; + for (i=1;i 0)) + iterate_model(coeff,pm,file); + fclose(file); + } + + if (outfile != NULL) + free(outfile); + if (infile != NULL) + free(infile); + free(vec); + for (i=0;i +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Fits an multivariate ARIMA model to the data and gives\ + the coefficients\n\tand the residues (or an iterated model)" + +unsigned long length=ULONG_MAX,exclude=0; +unsigned int dim=1,poles=10,ilength,ITER=50; +unsigned int arpoles=0,ipoles=0,mapoles=0,offset; +unsigned int verbosity=1; +char *outfile=NULL,*column=NULL,stdo=1,dimset=0,run_model=0,arimaset=0; +char *infile=NULL; +double **series,convergence=1.0e-3; + +double *my_average; +unsigned long ardim,armadim; +unsigned int **aindex; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l length of file [default is whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default is 0]\n"); + fprintf(stderr,"\t-m dimension [default is 1]\n"); + fprintf(stderr,"\t-c columns to read [default is 1,...,dimension]\n"); + fprintf(stderr,"\t-p order of initial AR-Fit [default is %u]\n",poles); + fprintf(stderr,"\t-P order of AR,I,MA-Fit [default is %u,%u,%u]\n", + arpoles,ipoles,mapoles); + fprintf(stderr,"\t-I # of arima iterations [default is %u]\n",ITER); + fprintf(stderr,"\t-e accuracy of convergence [default is %lf]\n",convergence); + fprintf(stderr,"\t-s length of iterated model [default no iteration]\n"); + fprintf(stderr,"\t-o output file name [default is 'datafile'.ari]\n"); + fprintf(stderr,"\t-V verbosity level [default is 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n\t\t" + "2='+ print residuals though iterating a model'\n\t\t" + "4='+ print original data plus residuals'\n"); + fprintf(stderr,"\t-h show these options\n\n"); + exit(0); +} + +void scan_options(int argc,char **argv) +{ + char *out; + + if ((out=check_option(argv,argc,'p','u')) != NULL) { + sscanf(out,"%u",&poles); + if (poles < 1) { + fprintf(stderr,"The order should at least be one!\n"); + exit(127); + } + } + if ((out=check_option(argv,argc,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(argv,argc,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(argv,argc,'m','u')) != NULL) { + sscanf(out,"%u",&dim); + dimset=1; + } + if ((out=check_option(argv,argc,'P','3')) != NULL) { + sscanf(out,"%u,%u,%u",&arpoles,&ipoles,&mapoles); + if ((arpoles+ipoles+mapoles)>0) + arimaset=1; + } + if ((out=check_option(argv,argc,'I','u')) != NULL) + sscanf(out,"%u",&ITER); + if ((out=check_option(argv,argc,'e','f')) != NULL) + sscanf(out,"%lf",&convergence); + if ((out=check_option(argv,argc,'c','u')) != NULL) + column=out; + if ((out=check_option(argv,argc,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(argv,argc,'s','u')) != NULL) { + sscanf(out,"%u",&ilength); + run_model=1; + } + if ((out=check_option(argv,argc,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void make_difference(void) +{ + unsigned long i,d; + + for (i=length-1;i>0;i--) + for (d=0;d= length) { + fprintf(stderr,"It makes no sense to have more poles than data! Exiting\n"); + exit(AR_MODEL_TOO_MANY_POLES); + } + if (arimaset) { + if ((arpoles >= length) || (mapoles >= length)) { + fprintf(stderr,"It makes no sense to have more poles than data! Exiting\n"); + exit(AR_MODEL_TOO_MANY_POLES); + } + } + + ardim=poles*dim; + aindex=make_ar_index(); + + check_alloc(vec=(double*)malloc(sizeof(double)*ardim)); + check_alloc(mat=(double**)malloc(sizeof(double*)*ardim)); + for (i=0;i mapoles)? arpoles:mapoles; + + offset += poles; + inverse=build_matrix(mat,armadim); + + for (i=0;i alldiff) + alldiff=xdiff[iter-1][i]; + realiter=iter; + if (alldiff < convergence) + iter=ITER; + + if (iter < ITER) { + for (i=0;i 0)) { + if (!arimaset) + iterate_model(coeff,pm,diff,NULL); + else + iterate_arima_model(coeff,pm,diff,NULL); + } + } + else { + file=fopen(outfile,"w"); + if (verbosity&VER_INPUT) + fprintf(stderr,"Opened %s for output\n",outfile); + if (arimaset) { + fprintf(file,"#convergence of residuals in arima fit\n"); + for (i=0;i 0)) { + if (!arimaset) + iterate_model(coeff,pm,diff,file); + else + iterate_arima_model(coeff,pm,diff,file); + } + fclose(file); + } + if (outfile != NULL) + free(outfile); + if (infile != NULL) + free(infile); + for (i=0;i +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Smoothes the output of the d2 program" + +#define MAXLENGTH 1000 + +unsigned int maxdim=UINT_MAX,mindim=1; +unsigned int verbosity=0xff; +int aver=1; +char rescaled=0; +char stout=1; +char *outfile=NULL; +char *infile=NULL; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr,"Usage: %s [options]\n",progname); + fprintf(stderr,"Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible datafile.\nStdin does NOT work.\n"); + fprintf(stderr,"\t-m dimension to start with [Default: 1]\n"); + fprintf(stderr,"\t-M dimension to end with [Default: whole file]\n"); + fprintf(stderr,"\t-a n average over (2n+1) values [Default: 1]\n"); + fprintf(stderr,"\t-E use rescaled data for the length scales\n\t\t" + "[Default: use units of data]\n"); + fprintf(stderr,"\t-o name of output file [Default: stdout,\n\t\t" + "-o without value means 'datafile'.av]\n"); + fprintf(stderr,"\t-V verbosity level [Default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'m','u')) != NULL) + sscanf(out,"%u",&mindim); + if ((out=check_option(in,n,'M','u')) != NULL) + sscanf(out,"%u",&maxdim); + if ((out=check_option(in,n,'a','u')) != NULL) + sscanf(out,"%u",&aver); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'E','n')) != NULL) + rescaled=1; + if ((out=check_option(in,n,'o','o')) != NULL) { + stout=0; + if (strlen(out) > 0) + outfile=out; + } +} + +int main(int argc,char **argv) +{ + char instr[1024]; + char *form1="%lf%lf",*form2="%*lf%lf%lf"; + char empty=0; + unsigned int howmany,size=1; + int j,k; + long dim; + double *eps,*y; + double avy,aveps,norm; + FILE *file,*fout=NULL; + + if ((argc < 2) || scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,0L,verbosity); + if (infile == NULL) { + fprintf(stderr,"You have to give a datafile. Exiting!\n"); + exit(127); + } + if (outfile == NULL) { + check_alloc(outfile=(char*)calloc(strlen(infile)+4,(size_t)1)); + sprintf(outfile,"%s.av",infile); + } + + check_alloc(eps=(double*)malloc(sizeof(double)*MAXLENGTH)); + check_alloc(y=(double*)malloc(sizeof(double)*MAXLENGTH)); + + file=fopen(infile,"r"); + + if (!stout) { + test_outfile(outfile); + fout=fopen(outfile,"w"); + if (verbosity&VER_INPUT) + fprintf(stderr,"Opened %s for writing\n",outfile); + } + else { + if (verbosity&VER_INPUT) + fprintf(stderr,"Writing to stdout\n"); + } + + if (mindim > maxdim) + mindim=maxdim; + norm=2.0*aver+1.0; + + while (fgets(instr,1024,file) != NULL) { + if (strlen(instr) != 1) { + if (instr[0] == '#') { + if (strstr(instr,"m= ") != NULL) { + sscanf(instr,"%*s %ld",&dim); + if ((dim >= mindim) && (dim <= maxdim)) { + howmany=0; + empty=0; + do { + if (fgets(instr,1024,file) == NULL) + exit(127); + if (strlen(instr) == 1) + empty=1; + if (!empty && (instr[0] != '#')) { + if (!rescaled) + sscanf(instr,form1,&eps[howmany],&y[howmany]); + else + sscanf(instr,form2,&y[howmany],&eps[howmany]); + howmany++; + if (!(howmany%MAXLENGTH)) { + check_alloc(realloc(eps,size*MAXLENGTH*sizeof(double))); + check_alloc(realloc(y,size*MAXLENGTH*sizeof(double))); + size++; + } + } + } while (!empty); + for (k=aver;k +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Estimates the Renyi entropy of Qth order\n\t\ +using a partition instead of a covering." + +typedef struct { + double *hist; + void *ptr; +} hliste; + +unsigned long LENGTH=ULONG_MAX,exclude=0; +unsigned int maxembed=10,dimension=1,DELAY=1,EPSCOUNT=20; +unsigned int verbosity=0xff; +double Q=2.0,EPSMIN=1.e-3,EPSMAX=1.0; +char dimset=0,epsminset=0,epsmaxset=0; +char *outfile=NULL; +char *column=NULL; + +int epsi; +unsigned long length; +double EPSFAKTOR; +unsigned int **which_dims; +double *histo; +double **series; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr,"Usage: %s [Options]\n",progname); + fprintf(stderr,"Options:\n"); + fprintf(stderr,"\t-l # of datapoints [Default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to ignore [Default: %lu]\n",exclude); + fprintf(stderr,"\t-M # of columns,maximal embedding dimension " + "[Default: %u,%u]\n",dimension,maxembed); + fprintf(stderr,"\t-c columns to read [Default: 1,...,#of compon.]\n"); + fprintf(stderr,"\t-d delay [Default: %u]\n",DELAY); + fprintf(stderr,"\t-Q order of the Renyi entropy [Default: %.1f]\n",Q); + fprintf(stderr,"\t-r minimal epsilon [Default: (data interval)/1000]\n"); + fprintf(stderr,"\t-R maximal epsilon [Default: data interval]\n"); + fprintf(stderr,"\t-# # of epsilons to use [Default: %u]\n",EPSCOUNT); + fprintf(stderr,"\t-o output file name [Default: 'datafile'.box]\n"); + fprintf(stderr,"\t-V verbosity level [Default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&LENGTH); + if ((out=check_option(in,n,'c','s')) != NULL) + column=out; + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'M','2')) != NULL) { + sscanf(out,"%u,%u",&dimension,&maxembed); + dimset=1; + } + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&DELAY); + if ((out=check_option(in,n,'Q','f')) != NULL) + sscanf(out,"%lf",&Q); + if ((out=check_option(in,n,'r','f')) != NULL) { + sscanf(out,"%lf",&EPSMIN); + epsminset=1; + } + if ((out=check_option(in,n,'R','f')) != NULL) { + sscanf(out,"%lf",&EPSMAX); + epsmaxset=1; + } + if ((out=check_option(in,n,'#','u')) != NULL) + sscanf(out,"%u",&EPSCOUNT); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'o','s')) != NULL) + outfile=out; +} + +hliste *make_histo(void) +{ + int i; + hliste *element; + + check_alloc(element=(hliste*)malloc(sizeof(hliste))); + element->ptr=NULL; + check_alloc(element->hist=(double*)malloc(sizeof(double)*maxembed*dimension)); + for (i=0;ihist[i]=0.0; + + return element; +} + +void next_dim(int wd,int n,unsigned int *first) +{ + int i,which,d1,comp; + double epsinv,norm,p; + unsigned int **act; + int *found,hf; + + comp=which_dims[wd][0]; + d1=which_dims[wd][1]*DELAY; + + epsinv=(double)epsi; + norm=(double)length; + + check_alloc(act=(unsigned int**)malloc(epsi*sizeof(int*))); + check_alloc(found=(int*)malloc(epsi*sizeof(int))); + + for (i=0;i maxinterval) + maxinterval=interval; + } + if (epsminset) + EPSMIN /= maxinterval; + if (epsmaxset) + EPSMAX /= maxinterval; + for (i=0;i= 1.0) + series[i][j] -= EPSMIN/2.0; + } + + check_alloc(histo=(double*)malloc(sizeof(double)*maxembed*dimension)); + check_alloc(deps=(double*)malloc(sizeof(double)*EPSCOUNT)); + check_alloc(which_dims=(unsigned int**)malloc(sizeof(int*)* + maxembed*dimension)); + for (i=0;i1) + EPSFAKTOR=pow(EPSMAX/EPSMIN,1.0/(double)(EPSCOUNT-1)); + else + EPSFAKTOR=1.0; + + length=LENGTH-(maxembed-1)*DELAY; + + heps=EPSMAX*EPSFAKTOR; + + for (k=0;kptr != NULL) + histo_el=histo_el->ptr; + + for (i=0;ihist[i]=histo[i]; + else + histo_el->hist[i]=log(histo[i])/(1.0-Q); + + histo_el->ptr=make_histo(); + histo_el=histo_el->ptr; + fHq=fopen(outfile,"w"); + if (verbosity&VER_INPUT) + fprintf(stderr,"Opened %s for writing\n",outfile); + + for (i=0;ihist[i],histo_el->hist[i]); + else + fprintf(fHq,"%e %e %e\n",deps[j]*maxinterval, + histo_el->hist[i],histo_el->hist[i]-histo_el->hist[i-1]); + histo_el=histo_el->ptr; + } + fprintf(fHq,"\n"); + } + fclose(fHq); + } + + return 0; +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/corr.c b/binaries/src/disembl/Tisean_3.0.1/source_c/corr.c new file mode 100644 index 0000000..06da07a --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/corr.c @@ -0,0 +1,179 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger. Last modified: Sep 3, 1999 */ +#include +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Estimates the autocorrelations of a data set" + +char *format,*outfile=NULL,stout=1,normalize=1; +unsigned int column=1; +unsigned int verbosity=0xff; +unsigned long tau=100,length=ULONG_MAX,exclude=0; +double *array; +double av,var; +char *infile=NULL; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [Options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l length [default is whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default 0]\n"); + fprintf(stderr,"\t-c column to read [default is 1]\n"); + fprintf(stderr,"\t-D corrlength [default is 100]\n"); + fprintf(stderr,"\t-n don\'t normalize to the variance" + " of the data [not set]\n"); + fprintf(stderr,"\t-o output_file [default is 'datafile'.cor; no -o" + " means stdout]\n"); + fprintf(stderr,"\t-V verbosity level [default is 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + fprintf(stderr,"\n"); + exit(0); +} + +void scan_options(int argc,char **argv) +{ + char *out; + + if ((out=check_option(argv,argc,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(argv,argc,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(argv,argc,'c','u')) != NULL) + sscanf(out,"%u",&column); + if ((out=check_option(argv,argc,'D','u')) != NULL) + sscanf(out,"%lu",&tau); + if ((out=check_option(argv,argc,'n','n')) != NULL) + normalize=0; + if ((out=check_option(argv,argc,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(argv,argc,'o','o')) != NULL) { + stout=0; + if (strlen(out) > 0) + outfile=out; + } +} + +double corr(long i) +{ + long j; + double c=0.0; + + for (j=0;j<(length-i);j++) + c += array[j]*array[j+i]; + + return c/(length-i); +} + +int main(int argc,char** argv) +{ + char stdi=0; + long i; + FILE *fout=NULL; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,&column,verbosity); + if (infile == NULL) + stdi=1; + + if (outfile == NULL) { + if (!stdi) { + check_alloc(outfile=(char*)calloc(strlen(infile)+5,(size_t)1)); + strcpy(outfile,infile); + strcat(outfile,".cor"); + } + else { + check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1)); + strcpy(outfile,"stdin.cor"); + } + } + if (!stout) + test_outfile(outfile); + + array=(double*)get_series(infile,&length,exclude,column,verbosity); + + if (tau >= length) + tau=length-1; + + variance(array,length,&av,&var); + + if (normalize) { + for (i=0;i +#include +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Estimates the correlation sum, -dimension and -entropy" + +/* output is written every WHEN seconds */ +#define WHEN 120 +/* Size of the field for box assisted neighbour searching + (has to be a power of 2)*/ +#define NMAX 256 +/* Size of the box for the scramble routine */ +#define SCBOX 4096 + +double **series; +long *scr; +char dimset=0,rescale_set=0,eps_min_set=0,eps_max_set=0; +char *FOUT=NULL; +double epsfactor,epsinv,lneps,lnfac; +double EPSMAX=1.0,EPSMIN=1.e-3; +double min,interval; +int imax=NMAX-1,howoften1,imin; +long box[NMAX][NMAX],*list,boxc1[NMAX],*listc1; +unsigned long nmax; +double **found,*norm; +unsigned long MINDIST=0,MAXFOUND=1000; +unsigned long length=ULONG_MAX,exclude=0; +unsigned int DIM=1,EMBED=10,HOWOFTEN=100,DELAY=1; +unsigned int verbosity=0x1; +char *column=NULL; +char *infile=NULL; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l datapoints [default is whole file]\n"); + fprintf(stderr,"\t-x exclude # points [default 0]\n"); + fprintf(stderr,"\t-d delay [default 1]\n"); + fprintf(stderr,"\t-M # of components, max. embedding dim. [default 1,10]\n"); + fprintf(stderr,"\t-c columns [default 1,...,# of components]\n"); + fprintf(stderr,"\t-t theiler-window [default 0]\n"); + fprintf(stderr,"\t-R max-epsilon " + "[default: max data interval]\n"); + fprintf(stderr,"\t-r min-epsilon [default: (max data interval)/1000]\n"); + fprintf(stderr,"\t-# #-of-epsilons [default 100]\n"); + fprintf(stderr,"\t-N max-#-of-pairs (0 means all) [default 1000]\n"); + fprintf(stderr,"\t-E use rescaled data [default: not rescaled]\n"); + fprintf(stderr," \t-o outfiles" + " [without exts.! default datafile[.d2][.h2][.stat][.c2]]\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n\t\t" + "2='+ output message each time output is done\n"); + + fprintf(stderr,"\t-h show these options\n"); + fprintf(stderr,"\n"); + exit(0); +} + +void scan_options(int n,char **argv) +{ + char *out; + + if ((out=check_option(argv,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(argv,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(argv,n,'c','s')) != NULL) + column=out; + if ((out=check_option(argv,n,'d','u')) != NULL) + sscanf(out,"%u",&DELAY); + if ((out=check_option(argv,n,'M','2')) != NULL) { + sscanf(out,"%u,%u",&DIM,&EMBED); + dimset=1; + } + if ((out=check_option(argv,n,'t','u')) != NULL) + sscanf(out,"%lu",&MINDIST); + if ((out=check_option(argv,n,'R','f')) != NULL) { + sscanf(out,"%lf",&EPSMAX); + eps_max_set=1; + } + if ((out=check_option(argv,n,'r','f')) != NULL) { + sscanf(out,"%lf",&EPSMIN); + eps_min_set=1; + } + if ((out=check_option(argv,n,'#','u')) != NULL) + sscanf(out,"%u",&HOWOFTEN); + if ((out=check_option(argv,n,'N','u')) != NULL) { + sscanf(out,"%lu",&MAXFOUND); + if (MAXFOUND == 0) + MAXFOUND=ULONG_MAX; + } + if ((out=check_option(argv,n,'E','n')) != NULL) + rescale_set=1; + if ((out=check_option(argv,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(argv,n,'o','o')) != NULL) + if (strlen(out) > 0) + FOUT=out; +} + +void scramble(void) +{ + long i,j,k,m; + unsigned long rnd,rndf,hlength,allscr=0; + long *scfound,*scnhelp,scnfound; + long scbox[SCBOX],lswap,element,scbox1=SCBOX-1; + double *rz,*schelp,sceps=(double)SCBOX-0.001,swap; + + hlength=length-(EMBED-1)*DELAY; + + if (sizeof(long) == 8) { + rndf=13*13*13*13; + rndf=rndf*rndf*rndf*13; + rnd=0x849178L; + } + else { + rndf=69069; + rnd=0x234571L; + } + for (i=0;i<1000;i++) + rnd=rnd*rndf+1; + + check_alloc(rz=(double*)malloc(sizeof(double)*hlength)); + check_alloc(scfound=(long*)malloc(sizeof(long)*hlength)); + check_alloc(scnhelp=(long*)malloc(sizeof(long)*hlength)); + check_alloc(schelp=(double*)malloc(sizeof(double)*hlength)); + + for (i=0;i MINDIST) { + count=0; + max=0.0; + maxi=howoften1; + small=0; + for (i=0;i max) { + max=dx; + if (max < EPSMIN) { + maxi=howoften1; + } + else { + maxi=(lneps-log(max))/lnfac; + } + } + if (count > 0) + for (k=imin;k<=maxi;k++) + found[count][k] += 1.0; + } + else { + small=1; + break; + } + count++; + } + if (small) + break; + } + } + element=list[element]; + } + } + } + + free(hs); +} + +void make_c2_1(int n) +{ + int i,x,i1,maxi; + long element,n1; + double hs,max; + + n1=scr[n]; + hs=series[0][n1]; + + x=(int)(hs*epsinv)&imax; + + for (i1=x-1;i1<=x+1;i1++) { + element=boxc1[i1&imax]; + while (element != -1) { + if (labs(element-n1) > MINDIST) { + max=fabs(hs-series[0][element]); + if (max <= EPSMAX) { + if (max < EPSMIN) + maxi=howoften1; + else + maxi=(lneps-log(max))/lnfac; + for (i=imin;i<=maxi;i++) + found[0][i] += 1.0; + } + } + element=listc1[element]; + } + } +} + +int main(int argc,char **argv) +{ + char smaller,stdi=0; + FILE *fout,*fstat; + char *outd1,*outc1,*outh1,*outstat; + int maxembed; + long i1,j1,x,y,sn,n,i,j,n1,n2; + long *oscr; + long lnorm; + double eps,*epsm,EPSMAX1,maxinterval; + time_t mytime,lasttime; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,NULL,verbosity); + if (infile == NULL) + stdi=1; + + if (FOUT == NULL) { + if (!stdi) { + check_alloc(FOUT=calloc(strlen(infile)+1,(size_t)1)); + strcpy(FOUT,infile); + } + else { + check_alloc(FOUT=calloc((size_t)6,(size_t)1)); + strcpy(FOUT,"stdin"); + } + } + if (column == NULL) + series=(double**)get_multi_series(infile,&length,exclude,&DIM,"",dimset, + verbosity); + else + series=(double**)get_multi_series(infile,&length,exclude,&DIM,column, + dimset,verbosity); + + if (rescale_set) { + for (i=0;i series[i][j]) + min=series[i][j]; + if (interval < series[i][j]) + interval=series[i][j]; + } + interval -= min; + if (interval > maxinterval) + maxinterval=interval; + } + } + if (!eps_max_set) + EPSMAX *= maxinterval; + if (!eps_min_set) + EPSMIN *= maxinterval; + EPSMAX=(fabs(EPSMAX) 1) { + x=(long)(series[0][sn]*epsinv)&imax; + y=(long)(series[1][sn]*epsinv)&imax; + } + else { + x=(long)(series[0][sn]*epsinv)&imax; + y=(long)(series[0][sn+DELAY]*epsinv)&imax; + } + list[sn]=box[x][y]; + box[x][y]=sn; + listc1[sn]=boxc1[x]; + boxc1[x]=sn; + + i=imin; + while (found[maxembed][i] >= MAXFOUND) { + smaller=1; + if (++i > howoften1) + break; + } + if (smaller) { + imin=i; + if (imin <= howoften1) { + EPSMAX=epsm[imin]; + epsinv=1.0/EPSMAX; + for (i1=0;i1 1) { + x=(long)(series[0][sn]*epsinv)&imax; + y=(long)(series[1][sn]*epsinv)&imax; + } + else { + x=(long)(series[0][sn]*epsinv)&imax; + y=(long)(series[0][sn+DELAY]*epsinv)&imax; + } + list[sn]=box[x][y]; + box[x][y]=sn; + listc1[sn]=boxc1[x]; + boxc1[x]=sn; + } + } + } + + if (imin <= howoften1) { + lnorm=n; + if (MINDIST > 0) { + sn=scr[n]; + n1=(sn-(long)MINDIST>=0)?sn-(long)MINDIST:0; + n2=(sn+MINDIST 1) + make_c2_dim(n); + make_c2_1(n); + for (i=imin;i WHEN) || (n == (nmax-1)) || + (imin > howoften1)) { + time(&lasttime); + fstat=fopen(outstat,"w"); + if (verbosity&VER_USR1) + fprintf(stderr,"Opened %s for writing\n",outstat); + fprintf(fstat,"Center points treated so far= %ld\n",n); + fprintf(fstat,"Maximal epsilon in the moment= %e\n",epsm[imin]); + fclose(fstat); + fout=fopen(outc1,"w"); + if (verbosity&VER_USR1) + fprintf(stderr,"Opened %s for writing\n",outc1); + fprintf(fout,"#center= %ld\n",n); + for (i=0;i 0.0) + fprintf(fout,"%e %e\n",eps,found[i][j]/norm[j]); + } + fprintf(fout,"\n\n"); + } + fclose(fout); + fout=fopen(outh1,"w"); + if (verbosity&VER_USR1) + fprintf(stderr,"Opened %s for writing\n",outh1); + fprintf(fout,"#center= %ld\n",n); + fprintf(fout,"#dim= 1\n"); + eps=EPSMAX1*epsfactor; + for (j=0;j 0.0) + fprintf(fout,"%e %e\n",eps,-log(found[0][j]/norm[j])); + } + fprintf(fout,"\n\n"); + for (i=1;i 0.0) && (found[i][j] > 0.0)) + fprintf(fout,"%e %e\n",eps,log(found[i-1][j]/found[i][j])); + } + fprintf(fout,"\n\n"); + } + fclose(fout); + fout=fopen(outd1,"w"); + if (verbosity&VER_USR1) + fprintf(stderr,"Opened %s for writing\n",outd1); + fprintf(fout,"#center= %ld\n",n); + for (i=0;i 0.0) && (found[i][j-1] > 0.0)) + fprintf(fout,"%e %e\n",eps,log(found[i][j-1]/found[i][j] + /norm[j-1]*norm[j])/lnfac); + } + fprintf(fout,"\n\n"); + } + fclose(fout); + if (imin > howoften1) + exit(0); + } + } + + if (infile != NULL) + free(infile); + free(outd1); + free(outh1); + free(outc1); + free(outstat); + free(list); + free(listc1); + free(scr); + free(oscr); + free(norm); + free(epsm); + for (i=0;i +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Produces delay vectors" + + +unsigned long length=ULONG_MAX; +unsigned long exclude=0; +unsigned int verbosity=0xff; +int delay=1; +unsigned int indim=1,embdim=2; +char *column=NULL,*format=NULL,*multidelay=NULL; +char *outfile=NULL; +char *infile=NULL; +char dimset=0,formatset=0,embset=0,mdelayset=0,delayset=0; +char stdo=1; + +double **series; +unsigned int *formatlist,*delaylist; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr,"\nUsage: %s [options]\n",progname); + fprintf(stderr,"Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted as a" + " possible datafile.\nIf no datafile is given stdin is read." + " Just - also means stdin\n"); + fprintf(stderr,"\t-l # of data [default: whole file]\n"); + fprintf(stderr,"\t-x # of rows to ignore [default: 0]\n"); + fprintf(stderr,"\t-M num. of columns to read [default: %u]\n",indim); + fprintf(stderr,"\t-c columns to read [default: 1,...,M]\n"); + fprintf(stderr,"\t-m dimension [default: 2]\n"); + fprintf(stderr,"\t-F format of the delay vector (see man page)\n"); + fprintf(stderr,"\t-d delay [default: 1]\n"); + fprintf(stderr,"\t-D multi delay list (see man page)\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-o output file [default: 'datafile'.del, " + "without -o: stdout]\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **str) +{ + char *out; + + if ((out=check_option(str,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(str,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(str,n,'c','s')) != NULL) + column=out; + if ((out=check_option(str,n,'M','u')) != NULL) { + sscanf(out,"%u",&indim); + dimset=1; + } + if ((out=check_option(str,n,'F','s')) != NULL) { + format=out; + formatset=1; + } + if ((out=check_option(str,n,'m','u')) != NULL) { + sscanf(out,"%u",&embdim); + embset=1; + } + if ((out=check_option(str,n,'d','u')) != NULL) { + sscanf(out,"%u",&delay); + delayset=1; + } + if ((out=check_option(str,n,'D','s')) != NULL) { + multidelay=out; + mdelayset=1; + } + if ((out=check_option(str,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(str,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void create_format_list(void) +{ + unsigned int i=0,num=0,sum=0; + + while (format[i]) { + if (!(isdigit(format[i])) && !(format[i] == ',')) { + fprintf(stderr,"Wrong format of -F parameter. Exiting!\n"); + exit(DELAY_WRONG_FORMAT_F); + } + i++; + } + + i=0; + while (format[i]) { + if (format[i++] == ',') + num++; + } + + check_alloc(formatlist=(unsigned int*)malloc(sizeof(int)*(num+1))); + for (i=0;i<=num;i++) { + sscanf(format,"%d",&formatlist[i]); + if (i +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Determines the maxima (minima) of a possibly multivariate\ + time series" + + +unsigned long length=ULONG_MAX,exclude=0; +char *column=NULL; +unsigned int verbosity=0xff; +unsigned int dim=1; +unsigned int which=1; +double mintime=0.0; +char dimset=0; +char maxima=1; +char stdo=1; +char *outfile=NULL; +char *infile=NULL; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr,"Usage: %s [options]\n",progname); + fprintf(stderr,"Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of points to use [Default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [Default: 0]\n"); + fprintf(stderr,"\t-m dimension (# of components) [Default: 1]\n"); + fprintf(stderr,"\t-c columns to read [Default: 1,...,# of components]\n"); + fprintf(stderr,"\t-w which component to maxi(mini)mize [Default: 1]\n"); + fprintf(stderr,"\t-z determine minima instead of maxima [Default: maxima]\n"); + fprintf(stderr,"\t-t minimal required time between two extrema " + "[Default: 0.0]\n"); + fprintf(stderr,"\t-o output file name [Default: 'datafile'.ext," + " without -o: stdout]\n"); + fprintf(stderr,"\t-V verbosity level [Default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'m','u')) != NULL) { + sscanf(out,"%u",&dim); + dimset=1; + } + if ((out=check_option(in,n,'c','s')) != NULL) + column=out; + if ((out=check_option(in,n,'w','u')) != NULL) + sscanf(out,"%u",&which); + if ((out=check_option(in,n,'z','n')) != NULL) + maxima=0; + if ((out=check_option(in,n,'t','f')) != NULL) + sscanf(out,"%lf",&mintime); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +int main(int argc,char **argv) +{ + char stdi=0; + unsigned long i,j; + double **series; + double x[3],a,b,c,lasttime,nexttime,time; + FILE *fout=NULL; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + which--; + if (which > (dim-1)) { + fprintf(stderr,"The component to maxi(mini)mize has to be smaller or equal" + "to the number\nof components! Exiting\n"); + exit(EXTREMA_STRANGE_COMPONENT); + } + infile=search_datafile(argc,argv,NULL,verbosity); + if (infile == NULL) + stdi=1; + + if (outfile == NULL) { + if (!stdi) { + check_alloc(outfile=(char*)calloc(strlen(infile)+5,(size_t)1)); + sprintf(outfile,"%s.ext",infile); + } + else { + check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1)); + sprintf(outfile,"stdin.ext"); + } + } + + if (column == NULL) + series=(double**)get_multi_series(infile,&length,exclude,&dim,"",dimset, + verbosity); + else + series=(double**)get_multi_series(infile,&length,exclude,&dim,column, + dimset,verbosity); + + if (!stdo) { + test_outfile(outfile); + fout=fopen(outfile,"w"); + if (verbosity&VER_INPUT) + fprintf(stderr,"Opened %s for writing\n",outfile); + } + else { + if (verbosity&VER_INPUT) + fprintf(stderr,"Writing to stdout\n"); + } + + lasttime=0.0; + x[0]=series[which][0]; + x[1]=series[which][1]; + for (i=2;i= x[0]) && (x[1] > x[2])) { + a=x[1]; + b=(x[2]-x[0])/2.0; + c=(x[2]-2.0*x[1]+x[0])/2.0; + time= -b/2.0/c; + nexttime=(double)i-1.0+time; + if ((nexttime-lasttime) >= mintime) { + for (j=0;j= mintime) { + for (j=0;j and sigma(eps) +*/ + +#include +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Determines the fraction of false nearest neighbors." + +char *outfile=NULL; +char *infile=NULL; +char stdo=1,dimset=0; +char *column=NULL; +unsigned long length=ULONG_MAX,exclude=0,theiler=0; +unsigned int delay=1,maxdim=5,minemb=1; +unsigned int comp=1,maxemb=5; +unsigned int verbosity=0xff; +double rt=2.0; +double eps0=1.0e-5; +double **series; +double aveps,vareps; +double varianz; + +#define BOX 1024 +int ibox=BOX-1; +long **box,*list; +unsigned int *vcomp,*vemb; +unsigned long toolarge; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data [default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to ignore [default: 0]\n"); + fprintf(stderr,"\t-c columns to read [default: 1]\n"); + fprintf(stderr,"\t-m min. test embedding dimension [default: %u]\n",minemb); + fprintf(stderr,"\t-M # of components,max. emb. dim. [default: %u,%u]\n", + comp,maxemb); + fprintf(stderr,"\t-d delay [default: 1]\n"); + fprintf(stderr,"\t-f escape factor [default: %.2lf]\n",rt); + fprintf(stderr,"\t-t theiler window [default: 0]\n"); + fprintf(stderr,"\t-o output file [default: 'datafile'.fnn; without -o" + " stdout]\n"); + fprintf(stderr,"\t-V verbosity level [default: 3]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n\t\t" + "2='+ information about the current state\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','s')) != NULL) + column=out; + if ((out=check_option(in,n,'m','u')) != NULL) + sscanf(out,"%u",&minemb); + if ((out=check_option(in,n,'M','2')) != NULL) { + sscanf(out,"%u,%u",&comp,&maxemb); + maxdim=comp*(maxemb+1); + dimset=1; + } + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&delay); + if ((out=check_option(in,n,'f','f')) != NULL) + sscanf(out,"%lf",&rt); + if ((out=check_option(in,n,'t','u')) != NULL) + sscanf(out,"%lu",&theiler); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void mmb(unsigned int hdim,unsigned int hemb,double eps) +{ + unsigned long i; + long x,y; + + for (x=0;x theiler) { + maxdx=fabs(series[0][n]-series[0][element]); + for (i=1;i<=dim;i++) { + ic=vcomp[i]; + i1=vemb[i]; + dx=fabs(series[ic][n+i1]-series[ic][element+i1]); + if (dx > maxdx) + maxdx=dx; + } + if ((maxdx < mindx) && (maxdx > 0.0)) { + which=element; + mindx=maxdx; + } + } + element=list[element]; + } + } + } + + if ((which != -1) && (mindx <= eps) && (mindx <= varianz/rt)) { + aveps += mindx; + vareps += mindx*mindx; + factor=0.0; + for (i=1;i<=comp;i++) { + ic=vcomp[dim+i]; + ie=vemb[dim+i]; + hfactor=fabs(series[ic][n+ie]-series[ic][which+ie])/mindx; + if (hfactor > factor) + factor=hfactor; + } + if (factor > rt) + toolarge++; + return 1; + } + return 0; +} + +int main(int argc,char **argv) +{ + char stdi=0; + FILE *file=NULL; + double min,inter=0.0,ind_inter,epsilon,av,ind_var; + char *nearest,alldone; + long i; + unsigned int dim,emb; + unsigned long donesofar; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,NULL,verbosity); + if (infile == NULL) + stdi=1; + + if (outfile == NULL) { + if (!stdi) { + check_alloc(outfile=(char*)calloc(strlen(infile)+5,(size_t)1)); + strcpy(outfile,infile); + strcat(outfile,".fnn"); + } + else { + check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1)); + strcpy(outfile,"stdin.fnn"); + } + } + if (!stdo) + test_outfile(outfile); + + if (column == NULL) + series=(double**)get_multi_series(infile,&length,exclude,&comp,"",dimset, + verbosity); + else + series=(double**)get_multi_series(infile,&length,exclude,&comp,column, + dimset,verbosity); + + for (i=0;iind_var)?ind_var:varianz; + inter=(inter +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Estimates the finite size Lyapunov exponent; Vulpiani et al." + + +#define NMAX 256 + +char *outfile=NULL; +char *infile=NULL; +char epsset=0,stdo=1; +double *series; +long box[NMAX][NMAX],*list; +unsigned int dim=2,delay=1,mindist=0; +unsigned int column=1; +unsigned int verbosity=0xff; +const unsigned int nmax=NMAX-1; +unsigned long length=ULONG_MAX,exclude=0; +double eps0=1.e-3,eps,epsinv,epsmax,epsfactor; +int howmany; + +struct fsle { + double time,factor,eps; + long count; +} *data; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of datapoints [default is whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default is 0]\n"); + fprintf(stderr,"\t-c column to read[default 1]\n"); + fprintf(stderr,"\t-m embedding dimension [default 2]\n"); + fprintf(stderr,"\t-d delay [default 1]\n"); + fprintf(stderr,"\t-t time window to omit [default 0]\n"); + fprintf(stderr,"\t-r epsilon size to start with [default " + "(std. dev. of data)/1000]\n"); + fprintf(stderr,"\t-o name of output file [default 'datafile'.fsl ," + "without -o: stdout]\n"); + fprintf(stderr,"\t-V verbosity level [default 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + fprintf(stderr,"\n"); + exit(0); +} + +void scan_options(int n,char **argv) +{ + char *out; + + if ((out=check_option(argv,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(argv,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(argv,n,'c','u')) != NULL) + sscanf(out,"%u",&column); + if ((out=check_option(argv,n,'m','u')) != NULL) + sscanf(out,"%u",&dim); + if ((out=check_option(argv,n,'d','u')) != NULL) + sscanf(out,"%u",&delay); + if ((out=check_option(argv,n,'t','u')) != NULL) + sscanf(out,"%u",&mindist); + if ((out=check_option(argv,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(argv,n,'r','f')) != NULL) { + epsset=1; + sscanf(out,"%lf",&eps0); + } + if ((out=check_option(argv,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void put_in_boxes(void) +{ + int i,j,x,y,del; + + for (i=0;i mindist) { + for (k=0;k eps) + break; + } + if (k==del1) { + if (dx < mindx) { + ok=1; + if (dx > 0.0) { + mindx=dx; + minelement=element; + } + } + } + } + element=list[element]; + } + } + } + + if ((minelement != -1) && (mindx < eps)) { + act += del1-delay+1; + minelement += del1-delay+1; + which=(int)(log(mindx/eps0)/log(epsfactor)); + if (which < 0) { + while ((dx=fabs(series[act]-series[minelement])) < data[0].eps) { + act++; + minelement++; + if ((act >= length) || (minelement >= length)) + return ok; + } + mindx=dx; + which=(int)(log(mindx/eps0)/log(epsfactor)); + } + for (i=which;i= length) || (minelement >= length)) + return ok; + stime++; + } + if (stime > 0) { + data[i].time += stime; + data[i].factor += log(dx/mindx); + data[i].count++; + } + mindx=dx; + } + } + return ok; +} + +int main(int argc,char **argv) +{ + char stdi=0,*done,alldone; + int i; + long n; + long maxlength; + double min,max,se_av,se_var,se0_av,se0_var; + FILE *file; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,&column,verbosity); + if (infile == NULL) + stdi=1; + + if (outfile == NULL) { + if (!stdi) { + check_alloc(outfile=(char*)calloc(strlen(infile)+5,(size_t)1)); + strcpy(outfile,infile); + strcat(outfile,".fsl"); + } + else { + check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1)); + strcpy(outfile,"stdin.fsl"); + } + } + if (!stdo) + test_outfile(outfile); + + series=(double*)get_series(infile,&length,exclude,column,verbosity); + variance(series,length,&se0_av,&se0_var); + rescale_data(series,length,&min,&max); + variance(series,length,&se_av,&se_var); + + if (epsset) { + eps0 /= max; + epsmax=se0_var; + } + else { + eps0 *= se_var; + epsmax=se_var; + } + if (eps0 >= epsmax) { + fprintf(stderr,"The minimal epsilon is too large. Exiting!\n"); + exit(FSLE__TOO_LARGE_MINEPS); + } + epsfactor=sqrt(2.0); + + howmany=(int)(log(epsmax/eps0)/log(epsfactor))+1; + check_alloc(data=(struct fsle*)malloc(sizeof(struct fsle)*howmany)); + eps=eps0/epsfactor; + for (i=0;i 0.0) + fprintf(file,"%e %e %ld\n",data[i].eps*max, + data[i].factor/data[i].time,data[i].count); + fclose(file); + } + else { + if (verbosity&VER_INPUT) + fprintf(stderr,"Writing to stdout\n"); + for (i=0;i 0.0) + fprintf(stdout,"%e %e %ld\n",data[i].eps*max, + data[i].factor/data[i].time,data[i].count); + } + + if (infile != NULL) + free(infile); + if (outfile != NULL) + free(outfile); + free(series); + free(data); + free(list); + free(done); + + return 0; +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/ghkss.c b/binaries/src/disembl/Tisean_3.0.1/source_c/ghkss.c new file mode 100644 index 0000000..053438b --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/ghkss.c @@ -0,0 +1,503 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger Last modified: Jun 10, 2006 */ +#include +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Multivariate noise reduction using the GHKSS algorithm" + + +#define BOX (unsigned int)1024 + +unsigned long length=ULONG_MAX,exclude=0; +unsigned int dim,qdim=2,delay=1,minn=50,iterations=1,comp=1,embed=5; +unsigned int verbosity=0xff; +double mineps,epsfac; +char *column=NULL; +char eps_set=0,euclidean=0,dimset=0,resize_eps; +char *outfile=NULL,stdo=1; +char *infile=NULL; + +double *d_min,*d_max,d_max_max; +double **series,**delta,**corr; +double *metric,trace; +long **box,*list; +unsigned long *flist; +int emb_offset; +unsigned int ibox=BOX-1; +unsigned int *index_comp,*index_embed; + +/*these are global to save time*/ +int *sorted; +double *av,**mat,*matarray,*eig; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr,"Usage: %s [options]\n",progname); + fprintf(stderr,"Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [Default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [Default: 0]\n"); + fprintf(stderr,"\t-c column to read [Default: 1,..,# of components]\n"); + fprintf(stderr,"\t-m # of components,embedding dimension [Default: 1,5]\n"); + fprintf(stderr,"\t-d delay [Default: 1]\n"); + fprintf(stderr,"\t-q dimension to project to [Default: 2]\n"); + fprintf(stderr,"\t-k minimal number of neighbours [Default: 50]\n"); + fprintf(stderr,"\t-r minimal neighbourhood size \n\t\t" + "[Default: (interval of data)/1000]\n"); + fprintf(stderr,"\t-i # of iterations [Default: 1]\n"); + fprintf(stderr,"\t-2 use euklidean metric [Default: non euklidean]\n"); + fprintf(stderr,"\t-o name of output file \n\t\t" + "[Default: 'datafile'.opt.n, where n is the iteration.\n\t\t" + " If no -o is given, the last iteration is also" + " written to stdout]\n"); + fprintf(stderr,"\t-V verbosity level [Default: 7]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n\t\t" + "2='+ average correction and trend'\n\t\t" + "4='+ how many points for which epsilon'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','s')) != NULL) { + column=out; + dimset=1; + } + if ((out=check_option(in,n,'m','2')) != NULL) + sscanf(out,"%u,%u",&comp,&embed); + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&delay); + if ((out=check_option(in,n,'q','u')) != NULL) + sscanf(out,"%u",&qdim); + if ((out=check_option(in,n,'k','u')) != NULL) + sscanf(out,"%u",&minn); + if ((out=check_option(in,n,'r','f')) != NULL) { + eps_set=1; + sscanf(out,"%lf",&mineps); + } + if ((out=check_option(in,n,'i','u')) != NULL) + sscanf(out,"%u",&iterations); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'2','n')) != NULL) + euclidean=1; + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void sort(double *x,int *n) +{ + long i,j,iswap; + double dswap; + + for (i=0;i x[i]) { + dswap=x[i]; + x[i]=x[j]; + x[j]=dswap; + iswap=n[i]; + n[i]=n[j]; + n[j]=iswap; + } +} + +void mmb(double eps) +{ + long i,x,y; + double ieps=1.0/eps; + + for (x=0;x eps) + break; + } + if (dx > eps) + break; + } + if (dx <= eps) + flist[nf++]=element; + element=list[element]; + } + } + } + return nf; +} + +void make_correction(unsigned long n,unsigned long nf) +{ + long i,i1,i2,j,j1,j2,k,k1,k2,hs; + double help; + + for (i=0;i d_max_max) + d_max_max=d_max[i]; + } + + if (!eps_set) + mineps=1./1000.; + else + mineps /= d_max_max; + epsfac=sqrt(2.0); + + check_alloc(box=(long**)malloc(sizeof(long*)*BOX)); + for (i=0;i= comp) && (i < ((long)dim-(long)comp))) + metric[i]=1.0; + else + metric[i]=1.0e3; + trace += 1./metric[i]; + } + } + + check_alloc(corr=(double**)malloc(sizeof(double*)*length)); + for (i=0;i= minn) { + make_correction(n,nfound); + ok[n]=epscount; + if (epscount == 1) + resize_eps=1; + allfound++; + } + else + all_done=0; + } + if (verbosity&VER_USR2) + fprintf(stderr,"Corrected %ld points with epsilon= %e\n",allfound, + epsilon*d_max_max); + epsilon *= epsfac; + epscount++; + } + if (verbosity&VER_USR2) + fprintf(stderr,"Start evaluating the trend\n"); + + epsilon=mineps; + allfound=0; + for (i=1;i +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Makes a histogram of the data" + +unsigned long length=ULONG_MAX; +unsigned long base=50; +unsigned long exclude=0; +unsigned int column=1; +unsigned int verbosity=0xff; +double size; +char my_stdout=1,gotsize=0; +char *outfile=NULL; +char *infile=NULL; + +double *series; +double average,var; +double min,max; +long *box; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted as a" + " possible datafile.\nIf no datafile is given stdin is read. " + " Just - also means stdin\n"); + fprintf(stderr,"\t-l length of file [default whole file]\n"); + fprintf(stderr,"\t-x # of lines to ignore [default %ld]\n",exclude); + fprintf(stderr,"\t-c column to read [default %d]\n",column); + fprintf(stderr,"\t-b # of intervals [default %ld]\n",base); + fprintf(stderr,"\t-o output file [default 'datafile'.dat ;" + " If no -o is given: stdout]\n"); + fprintf(stderr,"\t-V verbosity level [default 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **str) +{ + char *out; + + if ((out=check_option(str,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(str,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(str,n,'c','u')) != NULL) + sscanf(out,"%u",&column); + if ((out=check_option(str,n,'b','u')) != NULL) + sscanf(out,"%lu",&base); + if ((out=check_option(str,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(str,n,'o','o')) != NULL) { + my_stdout=0; + if (strlen(out) > 0) + outfile=out; + } +} + +int main(int argc,char **argv) +{ + char stdi=0; + unsigned long i,j; + double x,norm,size=1.0,size2=1.0; + FILE *fout; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,&column,verbosity); + if (infile == NULL) + stdi=1; + + if (outfile == NULL) { + if (!stdi) { + check_alloc(outfile=(char*)calloc(strlen(infile)+5,1)); + strcpy(outfile,infile); + strcat(outfile,".his"); + } + else { + check_alloc(outfile=(char*)calloc((size_t)10,1)); + strcpy(outfile,"stdin.his"); + } + } + if (!my_stdout) + test_outfile(outfile); + + series=(double*)get_series(infile,&length,exclude,column,verbosity); + variance(series,length,&average,&var); + rescale_data(series,length,&min,&max); + + + if (base > 0) { + check_alloc(box=(long*)malloc(sizeof(long)*base)); + for (i=0;i (1.0-size2)) + series[i]=1.0-size2; + j=(long)(series[i]*base); + box[j]++; + } + } + + norm=1.0/(double)length; + if (!my_stdout) { + fout=fopen(outfile,"w"); + if (verbosity&VER_INPUT) + fprintf(stderr,"Opened %s for writing\n",outfile); + fprintf(fout,"#interval of data: [%e:%e]\n",min,max+min); + fprintf(fout,"#average= %e\n",average); + fprintf(fout,"#standard deviation= %e\n",var); + for (i=0;i +#include +#include +#include +#include "routines/tsa.h" +#include + +#define WID_STR "Estimates the average forecast error for a local\n\t\ +linear fit as a function of the neighborhood size." + + +/*number of boxes for the neighbor search algorithm*/ +#define NMAX 256 + +unsigned int nmax=(NMAX-1); +long **box,*list; +unsigned long *found; +double *error; +double **series; + +char eps0set=0,eps1set=0,causalset=0,dimset=0; +char *outfile=NULL,stdo=1; +char *column=NULL; +unsigned int dim=1,embed=2,delay=1; +unsigned int verbosity=0xff; +int STEP=1; +double EPS0=1.e-3,EPS1=1.0,EPSF=1.2; +unsigned long LENGTH=ULONG_MAX,exclude=0,CLENGTH=ULONG_MAX,causal; +char *infile=NULL; +double **mat,*vec,*localav,*foreav,*hvec; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default: 0]\n"); + fprintf(stderr,"\t-c columns to read [default: 1,...,# of components]\n"); + fprintf(stderr,"\t-m # of components,embedding dimension [default: 1,2]\n"); + fprintf(stderr,"\t-d delay [default: 1]\n"); + fprintf(stderr,"\t-i iterations [default: length]\n"); + fprintf(stderr,"\t-r neighborhood size to start with [default:" + " (interval of data)/1000)]\n"); + fprintf(stderr,"\t-R neighborhood size to end with [default:" + " interval of data]\n"); + fprintf(stderr,"\t-f factor to increase size [default: 1.2]\n"); + fprintf(stderr,"\t-s steps to forecast [default: 1]\n"); + fprintf(stderr,"\t-C width of causality window [default: steps]\n"); + fprintf(stderr,"\t-o output file name [default: 'datafile.ll']\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&LENGTH); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','s')) != NULL) { + column=out; + dimset=1; + } + if ((out=check_option(in,n,'m','2')) != NULL) + sscanf(out,"%u,%u",&dim,&embed); + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&delay); + if ((out=check_option(in,n,'i','u')) != NULL) + sscanf(out,"%lu",&CLENGTH); + if ((out=check_option(in,n,'r','f')) != NULL) { + eps0set=1; + sscanf(out,"%lf",&EPS0); + } + if ((out=check_option(in,n,'R','f')) != NULL) { + eps1set=1; + sscanf(out,"%lf",&EPS1); + } + if ((out=check_option(in,n,'f','f')) != NULL) + sscanf(out,"%lf",&EPSF); + if ((out=check_option(in,n,'s','u')) != NULL) + sscanf(out,"%u",&STEP); + if ((out=check_option(in,n,'C','u')) != NULL) { + sscanf(out,"%lu",&causal); + causalset=1; + } + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void multiply_matrix(double **mat,double *vec) +{ + long i,j; + + for (i=0;i= hi) { + for (n=0;n maxinterval) + maxinterval=interval; + } + interval=maxinterval; + + check_alloc(list=(long*)malloc(sizeof(long)*LENGTH)); + check_alloc(found=(unsigned long*)malloc(sizeof(long)*LENGTH)); + check_alloc(hfound=(unsigned long*)malloc(sizeof(long)*LENGTH)); + check_alloc(box=(long**)malloc(sizeof(long*)*NMAX)); + for (i=0;i 2*(dim*embed+1)) { + make_fit(i,actfound); + pfound++; + avfound += (double)(actfound-1); + for (j=0;j 1) { + sumerror=0.0; + for (j=0;j 1) { + fprintf(stdout,"%e %e ",epsilon*interval,sumerror/(double)dim); + for (j=0;j 1) { + fprintf(file,"%e %e ",epsilon*interval,sumerror/(double)dim); + for (j=0;j +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Makes a local linear fit for multivariate data\n\ +and iterates a trajectory" + +#define NMAX 128 + +char onscreen=1,epsset=0,*outfile=NULL; +char *infile=NULL; +unsigned int nmax=(NMAX-1); +unsigned int verbosity=0xff; +long **box,*list,*found; +double **series,**cast; +double *interval,*min,epsilon; + +unsigned int embed=2,dim=1,dim1,DELAY=1; +char *column=NULL,dimset=0,do_zeroth=0; +int MINN=30; +unsigned long LENGTH=ULONG_MAX,FLENGTH=1000,exclude=0; +double EPS0=1.e-3,EPSF=1.2; + +double **mat,**imat,*vec,*localav,*foreav; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [Options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to be used [default whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default 0]\n"); + fprintf(stderr,"\t-c column [default 1,...,# of components]\n"); + fprintf(stderr,"\t-m #of components,embedding dimension [default 1,2]\n"); + fprintf(stderr,"\t-d delay for the embedding [default 1]\n"); + fprintf(stderr,"\t-L # of iterations [default 1000]\n"); + fprintf(stderr,"\t-k # of neighbors [default 30]\n"); + fprintf(stderr,"\t-r size of initial neighborhood [" + " default (data interval)/1000]\n"); + fprintf(stderr,"\t-f factor to increase size [default 1.2]\n"); + fprintf(stderr,"\t-0 perfom a zeroth order fit [default not set]\n"); + fprintf(stderr,"\t-o output file [default 'datafile'.cast;" + " no -o means write to stdout]\n"); + fprintf(stderr,"\t-V verbosity level [default 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&LENGTH); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','s')) != NULL) { + column=out; + dimset=1; + } + if ((out=check_option(in,n,'m','2')) != NULL) + sscanf(out,"%u,%u",&dim,&embed); + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&DELAY); + if ((out=check_option(in,n,'L','u')) != NULL) + sscanf(out,"%lu",&FLENGTH); + if ((out=check_option(in,n,'k','u')) != NULL) + sscanf(out,"%u",&MINN); + if ((out=check_option(in,n,'0','n')) != NULL) + do_zeroth=1; + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'r','f')) != NULL) { + epsset=1; + sscanf(out,"%lf",&EPS0); + } + if ((out=check_option(in,n,'f','f')) != NULL) + sscanf(out,"%lf",&EPSF); + if ((out=check_option(in,n,'o','o')) != NULL) { + onscreen=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void put_in_boxes(void) +{ + int i,j,n; + static int hdim; + double epsinv; + + hdim=(embed-1)*DELAY; + epsinv=1.0/epsilon; + for (i=0;imax) ? dx : max; + if (max > epsilon) { + toolarge=1; + break; + } + } + if (toolarge) + break; + } + if (max <= epsilon) + found[nfound++]=element; + element=list[element]; + } + } + } + return nfound; +} + +void multiply_matrix(double **mat,double *vec) +{ + double *hvec; + long i,j; + + check_alloc(hvec=(double*)malloc(sizeof(double)*dim*embed)); + for (i=0;i= hi) { + for (n=0;n maxinterval) + maxinterval=interval[i]; + } + + check_alloc(cast=(double**)malloc(sizeof(double*)*hdim)); + for (i=0;i= MINN) { + if (!do_zeroth) + make_fit(actfound,newcast); + else + make_zeroth(actfound,newcast); + if (onscreen) { + for (j=0;j 2.0) || (newcast[j] < -1.0)) { + fprintf(stderr,"Forecast failed. Escaping data region!\n"); + exit(NSTEP__ESCAPE_REGION); + } + } + + swap=cast[0]; + for (j=0;j +#include +#include +#include +#include "routines/tsa.h" +#include + +#define WID_STR "Estimates the average forecast error of a local\n\t\ +linear fit" + + +/*number of boxes for the neighbor search algorithm*/ +#define NMAX 512 + +unsigned int nmax=(NMAX-1),comp1,hdim,**indexes; +long **box,*list; +unsigned long *found,*hfound; +double **series; +double epsilon; +double **mat,**imat,*vec,*localav,*foreav; + +char epsset=0,causalset=0; +unsigned int verbosity=VER_INPUT|VER_FIRST_LINE; +unsigned int COMP=1,EMBED=2,DIM,DELAY=1,MINN=30,STEP=1; +double EPS0=1.e-3,EPSF=1.2; +unsigned long LENGTH=ULONG_MAX,exclude=0,CLENGTH=ULONG_MAX,causal; +char *infile=NULL,*COLUMN=NULL,*outfile=NULL; +char dimset=0,stout=1; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default: 0]\n"); + fprintf(stderr,"\t-c columns to read [default: 1]\n"); + fprintf(stderr,"\t-m # of components, embedding dimension " + "[default: %u,%u]\n",COMP,EMBED); + fprintf(stderr,"\t-d delay [default: 1]\n"); + fprintf(stderr,"\t-n iterations [default: length]\n"); + fprintf(stderr,"\t-k minimal number of neighbors for the fit " + "[default: 30]\n"); + fprintf(stderr,"\t-r neighborhoud size to start with " + "[default: (data interval)/1000]\n"); + fprintf(stderr,"\t-f factor to increase size [default: 1.2]\n"); + fprintf(stderr,"\t-s steps to forecast [default: 1]\n"); + fprintf(stderr,"\t-C width of causality window [default: steps]\n"); + fprintf(stderr,"\t-o output file [default 'datafile'.fce" + " no -o means write to stdout]\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n\t\t" + "2='+ print indiviual forecast errors'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&LENGTH); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','s')) != NULL) { + COLUMN=out; + dimset=1; + } + if ((out=check_option(in,n,'m','2')) != NULL) + sscanf(out,"%u,%u",&COMP,&EMBED); + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&DELAY); + if ((out=check_option(in,n,'n','u')) != NULL) + sscanf(out,"%lu",&CLENGTH); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'k','u')) != NULL) + sscanf(out,"%u",&MINN); + if ((out=check_option(in,n,'r','f')) != NULL) { + epsset=1; + sscanf(out,"%lf",&EPS0); + } + if ((out=check_option(in,n,'f','f')) != NULL) + sscanf(out,"%lf",&EPSF); + if ((out=check_option(in,n,'s','u')) != NULL) + sscanf(out,"%u",&STEP); + if ((out=check_option(in,n,'C','u')) != NULL) { + sscanf(out,"%lu",&causal); + causalset=1; + } + if ((out=check_option(in,n,'o','o')) != NULL) { + stout=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void put_in_boxes(void) +{ + int i,j,n; + double epsinv; + + epsinv=1.0/epsilon; + for (i=0;imax) ? dx : max; + if (max > epsilon) { + toolarge=1; + break; + } + if (toolarge) + break; + } + if (max <= epsilon) + hfound[nfound++]=element; + element=list[element]; + } + } + } + return nfound; +} + +void multiply_matrix(double **mat,double *vec) +{ + double *hvec; + long i,j; + + check_alloc(hvec=(double*)malloc(sizeof(double)*DIM)); + for (i=0;i MINN) { + make_fit(actfound,i,newcast); + for (j=0;j +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Simple lowpass filter in the time domain" + + +unsigned long length=ULONG_MAX,exclude=0; +unsigned int column=1,iterations=1; +unsigned int verbosity=0x1; +char *outfile=NULL,stdo=1; +char *infile=NULL; + +double *series,*new; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr,"Usage: %s [options]\n",progname); + fprintf(stderr,"Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of points to use [Default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [Default: 0]\n"); + fprintf(stderr,"\t-c column to read [Default: 1]\n"); + fprintf(stderr,"\t-i # of iterations [Default: 1]\n"); + fprintf(stderr,"\t-V verbosity level [Default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n\t\t" + "2='+ print each iteration to a separate file\n"); + fprintf(stderr,"\t-o output file name(s) [Default: 'datafile'.low.n,\n\t\t" + "where n is the number of the iteration.\n\t\t" + "without -o the last iteration is written to stdout.]\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','u')) != NULL) + sscanf(out,"%u",&column); + if ((out=check_option(in,n,'i','u')) != NULL) + sscanf(out,"%u",&iterations); + if ((out=check_option(in,n,'V','d')) != NULL) + sscanf(out,"%d",&verbosity); + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +int main(int argc,char **argv) +{ + char stdi=0; + char *ofname; + unsigned long i; + unsigned int iter; + FILE *file; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,&column,verbosity); + if (infile == NULL) + stdi=1; + + if (outfile == NULL) { + if (!stdi) { + check_alloc(outfile=(char*)calloc(strlen(infile)+5,(size_t)1)); + check_alloc(ofname=(char*)calloc(strlen(infile)+9,(size_t)1)); + sprintf(outfile,"%s.low",infile); + } + else { + check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1)); + check_alloc(ofname=(char*)calloc((size_t)14,(size_t)1)); + sprintf(outfile,"stdin.low"); + } + } + else + check_alloc(ofname=(char*)calloc(strlen(outfile)+10,(size_t)1)); + + series=(double*)get_series(infile,&length,exclude,column,verbosity); + check_alloc(new=(double*)malloc(sizeof(double)*length)); + + if (verbosity&VER_USR1) { + for (iter=1;iter<=iterations;iter++) { + new[0]=(2.0*series[0]+2.0*series[1])/4.0; + new[length-1]=(2.0*series[length-1]+2.0*series[length-2])/4.0; + for (i=1;i +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Estimates the maximal Lyapunov exponent using the Kantz\n\t\ +algorithm" + +#define BOX 128 +const unsigned int ibox=BOX-1; + +unsigned long length=ULONG_MAX; +unsigned long exclude=0; +unsigned long reference=ULONG_MAX; +unsigned int maxdim=2; +unsigned int mindim=2; +unsigned int delay=1; +unsigned int column=1; +unsigned int epscount=5; +unsigned int maxiter=50; +unsigned int window=0; +unsigned int verbosity=0xff; +double epsmin=1.e-3,epsmax=1.e-2; +char eps0set=0,eps1set=0; +char *outfile=NULL; +char *infile=NULL; + +double *series,**lyap; +long box[BOX][BOX],*liste,**lfound,*found,**count; +double max,min; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be " + "interpreted as a possible datafile.\nIf no datafile " + "is given stdin is read. Just - also means stdin\n"); + fprintf(stderr,"\t-l # of data [default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default: 0]\n"); + fprintf(stderr,"\t-c column to read [default: 1]\n"); + fprintf(stderr,"\t-M maxdim [default: 2]\n"); + fprintf(stderr,"\t-m mindim [default: 2]\n"); + fprintf(stderr,"\t-d delay [default: 1]\n"); + fprintf(stderr,"\t-r mineps [default: (data interval)/1000]\n"); + fprintf(stderr,"\t-R maxeps [default: (data interval)/100]\n"); + fprintf(stderr,"\t-# # of eps [default: 5]\n"); + fprintf(stderr,"\t-n # of reference points [default: # of data]\n"); + fprintf(stderr,"\t-s # of iterations [default: 50]\n"); + fprintf(stderr,"\t-t time window [default: 0]\n"); + fprintf(stderr,"\t-o outfile [default: 'datafile'.lyap]\n"); + fprintf(stderr,"\t-V verbosity level [default: 3]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n\t\t" + "2='+ plus statistics'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **str) +{ + char *out; + + if ((out=check_option(str,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(str,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(str,n,'c','u')) != NULL) + sscanf(out,"%u",&column); + if ((out=check_option(str,n,'M','u')) != NULL) + sscanf(out,"%u",&maxdim); + if ((out=check_option(str,n,'m','u')) != NULL) + sscanf(out,"%u",&mindim); + if ((out=check_option(str,n,'d','u')) != NULL) + sscanf(out,"%u",&delay); + if ((out=check_option(str,n,'r','f')) != NULL) { + eps0set=1; + sscanf(out,"%lf",&epsmin); + } + if ((out=check_option(str,n,'R','f')) != NULL) { + eps1set=1; + sscanf(out,"%lf",&epsmax); + } + if ((out=check_option(str,n,'#','u')) != NULL) + sscanf(out,"%u",&epscount); + if ((out=check_option(str,n,'n','u')) != NULL) + sscanf(out,"%lu",&reference); + if ((out=check_option(str,n,'s','u')) != NULL) + sscanf(out,"%u",&maxiter); + if ((out=check_option(str,n,'t','u')) != NULL) + sscanf(out,"%u",&window); + if ((out=check_option(str,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(str,n,'o','o')) != NULL) + if (strlen(out) > 0) + outfile=out; +} + +void put_in_boxes(double eps) +{ + unsigned long i; + long j,k; + static unsigned long blength; + + blength=length-(maxdim-1)*delay-maxiter; + + for (i=0;i (act+lwindow))) { + dx=sqr(series[act]-series[element]); + if (dx <= eps2) { + for (k=1;k 0.0){ + lcount[j][i]++; + lfactor[j][i] += dx[i]; + } + } + } + for (i=mindim-2;i= epsmax) { + epsmax=epsmin; + epscount=1; + } + + if (reference > (length-maxiter-(maxdim-1)*delay)) + reference=length-maxiter-(maxdim-1)*delay; + if ((maxiter+(maxdim-1)*delay) >= length) { + fprintf(stderr,"Too few points to handle these parameters!\n"); + exit(LYAP_K__MAXITER_TOO_LARGE); + } + + if (maxdim < 2) + maxdim=2; + if (mindim < 2) + mindim=2; + if (mindim > maxdim) + maxdim=mindim; + + check_alloc(liste=(long*)malloc(sizeof(long)*(length))); + check_alloc(found=(long*)malloc(sizeof(long)*(maxdim-1))); + check_alloc(lfound=(long**)malloc(sizeof(long*)*(maxdim-1))); + for (i=0;i +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Estimates the maximal Lyapunov exponent; Rosenstein et al." + +#define NMAX 256 + +char *outfile=NULL; +char *infile=NULL; +char epsset=0; +double *series,*lyap; +long box[NMAX][NMAX],*list; +unsigned int dim=2,delay=1,steps=10,mindist=0; +unsigned int column=1; +unsigned int verbosity=0xff; +const unsigned int nmax=NMAX-1; +unsigned long length=ULONG_MAX,exclude=0; +long *found; +double eps0=1.e-3,eps,epsinv; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of datapoints [default is whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default is 0]\n"); + fprintf(stderr,"\t-c column to read[default 1]\n"); + fprintf(stderr,"\t-m embedding dimension [default 2]\n"); + fprintf(stderr,"\t-d delay [default 1]\n"); + fprintf(stderr,"\t-t time window to omit [default 0]\n"); + fprintf(stderr,"\t-r epsilon size to start with [default " + "(data interval)/1000]\n"); + fprintf(stderr,"\t-s # of iterations [default 10]\n"); + fprintf(stderr,"\t-o name of output file [default 'datafile'.ros]\n"); + fprintf(stderr,"\t-V verbosity level [default 3]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n\t\t" + "2='+ give more detailed information about the length scales\n"); + fprintf(stderr,"\t-h show these options\n"); + fprintf(stderr,"\n"); + exit(0); +} + +void scan_options(int n,char **argv) +{ + char *out; + + if ((out=check_option(argv,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(argv,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(argv,n,'c','u')) != NULL) + sscanf(out,"%u",&column); + if ((out=check_option(argv,n,'m','u')) != NULL) + sscanf(out,"%u",&dim); + if ((out=check_option(argv,n,'d','u')) != NULL) + sscanf(out,"%u",&delay); + if ((out=check_option(argv,n,'t','u')) != NULL) + sscanf(out,"%u",&mindist); + if ((out=check_option(argv,n,'r','f')) != NULL) { + epsset=1; + sscanf(out,"%lf",&eps0); + } + if ((out=check_option(argv,n,'s','u')) != NULL) + sscanf(out,"%u",&steps); + if ((out=check_option(argv,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(argv,n,'o','o')) != NULL) + if (strlen(out) > 0) + outfile=out; +} + +void put_in_boxes(void) +{ + int i,j,x,y,del; + + for (i=0;i mindist) { + dx=0.0; + for (k=0;k eps*eps) + break; + } + if (k==del1) { + if (dx < mindx) { + ok=1; + if (dx > 0.0) { + mindx=dx; + minelement=element; + } + } + } + } + element=list[element]; + } + } + } + if ((minelement != -1) ) { + act--; + minelement--; + for (i=0;i<=steps;i++) { + act++; + minelement++; + dx=0.0; + for (j=0;j 0.0) { + found[i]++; + lyap[i] += log(dx); + } + } + } + return ok; +} + +int main(int argc,char **argv) +{ + char stdi=0,*done,alldone; + int i; + long n; + long maxlength; + double min,max; + FILE *file; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,&column,verbosity); + if (infile == NULL) + stdi=1; + + if (outfile == NULL) { + if (!stdi) { + check_alloc(outfile=(char*)calloc(strlen(infile)+5,(size_t)1)); + strcpy(outfile,infile); + strcat(outfile,".ros"); + } + else { + check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1)); + strcpy(outfile,"stdin.ros"); + } + } + test_outfile(outfile); + + series=(double*)get_series(infile,&length,exclude,column,verbosity); + rescale_data(series,length,&min,&max); + + if (epsset) + eps0 /= max; + + check_alloc(list=(long*)malloc(length*sizeof(long))); + check_alloc(lyap=(double*)malloc((steps+1)*sizeof(double))); + check_alloc(found=(long*)malloc((steps+1)*sizeof(long))); + check_alloc(done=(char*)malloc(length)); + + for (i=0;i<=steps;i++) { + lyap[i]=0.0; + found[i]=0; + } + for (i=0;i +#include +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Estimates the spectrum of Lyapunov exponents using the\n\t\ +method of Sano and Sawada." + +#define OUT 10 + +#define BOX 512 +#define EPSMAX 1.0 +#define DELAY 1 + +char epsset=0,stdo=1; +char INVERSE,*outfile=NULL; +char *infile=NULL; +char dimset=0; +char *COLUMNS=NULL; +unsigned long LENGTH=ULONG_MAX,ITERATIONS,exclude=0; +unsigned int EMBED=2,DIMENSION=1/*,DELAY=1*/,MINNEIGHBORS=30; +unsigned int verbosity=0xff; +double EPSSTEP=1.2; + +double **series,*averr,avneig=0.0,aveps=0.0; +double **mat,*vec,*abstand; +double epsmin; +long imax=BOX-1,count=0; +long **box,*list; +unsigned long *found; +unsigned int alldim,**indexes; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of datapoints [default is whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default is 0]\n"); + fprintf(stderr,"\t-c column to read[default 1]\n"); + fprintf(stderr,"\t-m # of components,embedding dimension [default %d,%d]\n", + DIMENSION,EMBED); + // fprintf(stderr,"\t-d delay [default %d]\n",DELAY); + fprintf(stderr,"\t-r epsilon size to start with [default " + "(data interval)/1000]\n"); + fprintf(stderr,"\t-f factor to increase epsilon [default: 1.2]\n"); + fprintf(stderr,"\t-k # of neighbors to use [default: 30]\n"); + fprintf(stderr,"\t-n # of iterations [default: length]\n"); + fprintf(stderr,"\t-I invert the time series [default: no]\n"); + fprintf(stderr,"\t-o name of output file [default 'datafile'.lyaps]\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + fprintf(stderr,"\n"); + exit(0); +} + +void scan_options(int n,char **argv) +{ + char *out; + + if ((out=check_option(argv,n,'l','u')) != NULL) + sscanf(out,"%lu",&LENGTH); + if ((out=check_option(argv,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(argv,n,'c','s')) != NULL) + COLUMNS=out; + /* if ((out=check_option(argv,n,'d','u')) != NULL) + sscanf(out,"%u",&DELAY);*/ + if ((out=check_option(argv,n,'m','2')) != NULL) { + sscanf(out,"%u,%u",&DIMENSION,&EMBED); + dimset=1; + } + if ((out=check_option(argv,n,'n','u')) != NULL) + sscanf(out,"%lu",&ITERATIONS); + if ((out=check_option(argv,n,'r','f')) != NULL) { + epsset=1; + sscanf(out,"%lf",&epsmin); + } + if ((out=check_option(argv,n,'f','f')) != NULL) + sscanf(out,"%lf",&EPSSTEP); + if ((out=check_option(argv,n,'k','u')) != NULL) + sscanf(out,"%u",&MINNEIGHBORS); + if ((out=check_option(argv,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(argv,n,'I','n')) != NULL) + INVERSE=1; + if ((out=check_option(argv,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +double sort(long act,unsigned long* nfound,char *enough) +{ + double maxeps=0.0,dx,dswap,maxdx; + long self=0,i,j,del,hf,iswap,n1; + unsigned long imax=*nfound; + + *enough=0; + + for (i=0;i maxdx) maxdx=dx; + } + abstand[i]=maxdx; + } + else { + self=i; + } + } + + if (self != (imax-1)) { + abstand[self]=abstand[imax-1]; + found[self]=found[imax-1]; + } + + for (i=0;i= epsmin)) { + *nfound=MINNEIGHBORS; + *enough=1; + maxeps=abstand[MINNEIGHBORS-1]; + + return maxeps; + } + + for (i=MINNEIGHBORS;i epsmin) { + (*nfound)=i+1; + *enough=1; + maxeps=abstand[i]; + + return maxeps; + } + } + + maxeps=abstand[imax-2]; + + return maxeps; +} + +void make_dynamics(double **dynamics,long act) +{ + long i,hi,j,hj,k,t=act,d; + unsigned long nfound=0; + double **hser,**imat; + double foundeps=0.0,epsilon,hv,hv1; + double new_vec; + char got_enough; + + check_alloc(hser=(double**)malloc(sizeof(double*)*DIMENSION)); + for (i=0;i EPSMAX) + epsilon=EPSMAX; + make_multi_box(series,box,list,LENGTH-DELAY,BOX,DIMENSION,EMBED, + DELAY,epsilon); + nfound=find_multi_neighbors(series,box,list,hser,LENGTH-DELAY,BOX, + DIMENSION,EMBED,DELAY,epsilon,found); + if (nfound > MINNEIGHBORS) { + foundeps=sort(act,&nfound,&got_enough); + if (got_enough) + break; + } + } while (epsilon < EPSMAX); + + free(hser); + + avneig += nfound; + aveps += foundeps; + if (!epsset) + epsmin=aveps/count; + if (nfound < MINNEIGHBORS) { + fprintf(stderr,"#Not enough neighbors found. Exiting\n"); + exit(LYAP_SPEC_NOT_ENOUGH_NEIGHBORS); + } + + for (i=0;i<=alldim;i++) { + vec[i]=0.0; + for (j=0;j<=alldim;j++) + mat[i][j]=0.0; + } + + for (i=0;i (LENGTH-DELAY*(EMBED-1)-1)) { + fprintf(stderr,"Your time series is not long enough to find %d neighbors!" + " Exiting.\n",MINNEIGHBORS); + exit(LYAP_SPEC_DATA_TOO_SHORT); + } + + check_alloc(min=(double*)malloc(sizeof(double)*DIMENSION)); + check_alloc(interval=(double*)malloc(sizeof(double)*DIMENSION)); + check_alloc(av=(double*)malloc(sizeof(double)*DIMENSION)); + check_alloc(var=(double*)malloc(sizeof(double)*DIMENSION)); + check_alloc(averr=(double*)malloc(sizeof(double)*DIMENSION)); + maxinterval=0.0; + for (i=0;i maxinterval) + maxinterval=interval[i]; + variance(series[i],LENGTH,&av[i],&var[i]); + } + + if (INVERSE) { + check_alloc(hseries=(double*)malloc(sizeof(double)*LENGTH)); + for (j=0;j(LENGTH-DELAY)) + start=LENGTH-DELAY; + + if (!stdo) { + file=fopen(outfile,"w"); + if (verbosity&VER_INPUT) + fprintf(stderr,"Opened %s for writing\n",outfile); + } + else { + if (verbosity&VER_INPUT) + fprintf(stderr,"Writing to stdout\n"); + } + + check_alloc(abstand=(double*)malloc(sizeof(double)*LENGTH)); + + time(&lasttime); + for (i=(EMBED-1)*DELAY;i OUT) || (i == (start-1))) { + time(&lasttime); + if (!stdo) { + fprintf(file,"%ld ",count); + for (j=0;j +#include +#include +#include +#include "routines/tsa.h" +#include + +#define WID_STR "Estimates the average forecast error for a local\n\t\ +constant fit as a function of the neighborhood size." + + +/*number of boxes for the neighbor search algorithm*/ +#define NMAX 256 + +unsigned int nmax=(NMAX-1); +long **box,*list; +unsigned long *found; +double *error; +double **series; + +char eps0set=0,eps1set=0,causalset=0,dimset=0; +char *outfile=NULL,stdo=1; +char *column=NULL; +unsigned int dim=1,embed=2,delay=1; +unsigned int verbosity=0xff; +int STEP=1; +double EPS0=1.e-3,EPS1=1.0,EPSF=1.2; +unsigned long LENGTH=ULONG_MAX,exclude=0,CLENGTH=ULONG_MAX,causal; +char *infile=NULL; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default: 0]\n"); + fprintf(stderr,"\t-c columns to read [default: 1,...,# of components]\n"); + fprintf(stderr,"\t-m # of components,embedding dimension [default: 1,2]\n"); + fprintf(stderr,"\t-d delay [default: 1]\n"); + fprintf(stderr,"\t-i iterations [default: length]\n"); + fprintf(stderr,"\t-r neighborhood size to start with [default:" + " (interval of data)/1000)]\n"); + fprintf(stderr,"\t-R neighborhood size to end with [default:" + " interval of data]\n"); + fprintf(stderr,"\t-f factor to increase size [default: 1.2]\n"); + fprintf(stderr,"\t-s steps to forecast [default: 1]\n"); + fprintf(stderr,"\t-C width of causality window [default: steps]\n"); + fprintf(stderr,"\t-o output file name [default: 'datafile.lm']\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&LENGTH); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','s')) != NULL) { + column=out; + dimset=1; + } + if ((out=check_option(in,n,'m','2')) != NULL) + sscanf(out,"%u,%u",&dim,&embed); + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&delay); + if ((out=check_option(in,n,'i','u')) != NULL) + sscanf(out,"%lu",&CLENGTH); + if ((out=check_option(in,n,'r','f')) != NULL) { + eps0set=1; + sscanf(out,"%lf",&EPS0); + } + if ((out=check_option(in,n,'R','f')) != NULL) { + eps1set=1; + sscanf(out,"%lf",&EPS1); + } + if ((out=check_option(in,n,'f','f')) != NULL) + sscanf(out,"%lf",&EPSF); + if ((out=check_option(in,n,'s','u')) != NULL) + sscanf(out,"%u",&STEP); + if ((out=check_option(in,n,'C','u')) != NULL) { + sscanf(out,"%lu",&causal); + causalset=1; + } + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void make_fit(long act,unsigned long number) +{ + double *si,cast; + long i,j; + + for (i=0;i maxinterval) + maxinterval=interval; + } + interval=maxinterval; + + check_alloc(list=(long*)malloc(sizeof(long)*LENGTH)); + check_alloc(found=(unsigned long*)malloc(sizeof(long)*LENGTH)); + check_alloc(hfound=(unsigned long*)malloc(sizeof(long)*LENGTH)); + check_alloc(box=(long**)malloc(sizeof(long*)*NMAX)); + for (i=0;i 2*(dim*embed+1)) { + make_fit(i,actfound); + pfound++; + avfound += (double)(actfound-1); + for (j=0;j 1) { + sumerror=0.0; + for (j=0;j 1) { + fprintf(stdout,"%e %e ",epsilon*interval,sumerror/(double)dim); + for (j=0;j 1) { + fprintf(file,"%e %e ",epsilon*interval,sumerror/(double)dim); + for (j=0;j +#include +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Makes a local zeroth order forecast for multivariate data\n\ +and iterates a trajectory" + +#define NMAX 128 + +char onscreen=1,epsset=0,*outfile=NULL,setsort=1,setnoise=0; +char *infile=NULL; +unsigned int nmax=(NMAX-1); +unsigned int verbosity=0xff; +long **box,*list,*found; +double **series,**cast,*abstand,*var; +double epsilon; + +unsigned int embed=2,dim=1,dim1,DELAY=1; +char *column=NULL,dimset=0; +unsigned int MINN=50; +unsigned int **indexes; +unsigned long LENGTH=ULONG_MAX,FLENGTH=1000,exclude=0; +unsigned long seed=0x9074325L; +double EPS0=1.e-3,EPSF=1.2,Q=10.0; + +double **mat,*vec,*hsum,*newav; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [Options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to be used [default whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default 0]\n"); + fprintf(stderr,"\t-c column [default 1,...,# of components]\n"); + fprintf(stderr,"\t-m #of components,embedding dimension [default 1,2]\n"); + fprintf(stderr,"\t-d delay for the embedding [default 1]\n"); + fprintf(stderr,"\t-L # of iterations [default 1000]\n"); + fprintf(stderr,"\t-k # of neighbors [default %u]\n",MINN); + fprintf(stderr,"\t-K fix # of neighbors [default no]\n"); + fprintf(stderr,"\t-%% # variance of noise [default %3.1lf]\n",Q); + fprintf(stderr,"\t-I seed for the rnd-generator (If seed=0, the time\n" + "\t\tcommand is used to set the seed) [Default: fixed]\n"); + fprintf(stderr,"\t-r size of initial neighborhood [" + " default (data interval)/1000]\n"); + fprintf(stderr,"\t-f factor to increase size [default 1.2]\n"); + fprintf(stderr,"\t-o output file [default 'datafile'.lzr;" + " no -o means write to stdout]\n"); + fprintf(stderr,"\t-V verbosity level [default 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&LENGTH); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','s')) != NULL) { + column=out; + dimset=1; + } + if ((out=check_option(in,n,'m','2')) != NULL) + sscanf(out,"%u,%u",&dim,&embed); + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&DELAY); + if ((out=check_option(in,n,'L','u')) != NULL) + sscanf(out,"%lu",&FLENGTH); + if ((out=check_option(in,n,'k','u')) != NULL) + sscanf(out,"%u",&MINN); + if ((out=check_option(in,n,'K','n')) != NULL) + setsort=1; + if ((out=check_option(in,n,'I','u')) != NULL) { + sscanf(out,"%lu",&seed); + if (seed == 0) + seed=(unsigned long)time((time_t*)&seed); + } + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'r','f')) != NULL) { + epsset=1; + sscanf(out,"%lf",&EPS0); + } + if ((out=check_option(in,n,'f','f')) != NULL) + sscanf(out,"%lf",&EPSF); + if ((out=check_option(in,n,'%','f')) != NULL) { + sscanf(out,"%lf",&Q); + if (Q>0.0) + setnoise=1; + } + if ((out=check_option(in,n,'o','o')) != NULL) { + onscreen=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void sort(unsigned long nfound) +{ + double dx,dswap; + int i,j,k,hf,iswap,hdim; + + hdim=(embed-1)*DELAY; + + for (i=0;i abstand[i]) abstand[i]=dx; + } + } + } + + for (i=0;imax) ? dx : max; + if (max > epsilon) { + toolarge=1; + break; + } + } + if (max <= epsilon) + found[nfound++]=element; + element=list[element]; + } + } + } + return nfound; +} + +void make_zeroth(int number,double *newcast) +{ + long d,i; + double *sd; + + for (d=0;d maxinterval) + maxinterval=interval[i]; + } + + if (epsset) + EPS0 /= maxinterval; + + check_alloc(cast=(double**)malloc(sizeof(double*)*hdim)); + for (i=0;i= MINN) { + if (setsort) { + epsilon0 += epsilon; + count++; + sort(actfound); + actfound=MINN; + } + make_zeroth(actfound,newcast); + if (onscreen) { + for (j=0;j +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Estimates the average forecast error for a zeroth\n\t\ +order fit from a multidimensional time series" + + +#ifndef _MATH_H +#include +#endif + +/*number of boxes for the neighbor search algorithm*/ +#define NMAX 512 + +unsigned int nmax=(NMAX-1); +long **box,*list; +unsigned long *found; +double **series,**diffs; +double interval,min,epsilon; + +char epsset=0,dimset=0,clengthset=0,causalset=0; +char *infile=NULL; +char *outfile=NULL,stdo=1; +char *COLUMNS=NULL; +unsigned int embed=2,dim=1,DELAY=1,MINN=30; +unsigned long STEP=1,causal; +unsigned int verbosity=0x1; +double EPS0=1.e-3,EPSF=1.2; +unsigned long refstep=1; +unsigned long LENGTH=ULONG_MAX,exclude=0,CLENGTH=ULONG_MAX; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default: 0]\n"); + fprintf(stderr,"\t-c columns to read [default: 1,...,X]\n"); + fprintf(stderr,"\t-m dimension and embedding dimension" + " [default: %d,%d]\n",dim,embed); + fprintf(stderr,"\t-d delay [default: %d]\n",DELAY); + fprintf(stderr,"\t-n # of reference points [default: length]\n"); + fprintf(stderr,"\t-S temporal distance between the reference points" + " [default: %lu]\n",refstep); + fprintf(stderr,"\t-k minimal number of neighbors for the fit " + "[default: %d]\n",MINN); + fprintf(stderr,"\t-r neighborhoud size to start with " + "[default: (data interval)/1000]\n"); + fprintf(stderr,"\t-f factor to increase size [default: 1.2]\n"); + fprintf(stderr,"\t-s steps to forecast [default: 1]\n"); + fprintf(stderr,"\t-C width of causality window [default: steps]\n"); + fprintf(stderr,"\t-o output file [default: 'datafile.zer'," + " without -o: stdout]\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n\t\t" + "2='give individual forecast errors for the max step'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&LENGTH); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','s')) != NULL) + COLUMNS=out; + if ((out=check_option(in,n,'m','2')) != NULL) { + dimset=1; + sscanf(out,"%u%*c%u",&dim,&embed); + if (embed == 0) + embed=1; + } + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&DELAY); + if ((out=check_option(in,n,'n','u')) != NULL) { + sscanf(out,"%lu",&CLENGTH); + clengthset=1; + } + if ((out=check_option(in,n,'S','u')) != NULL) + sscanf(out,"%lu",&refstep); + if ((out=check_option(in,n,'k','u')) != NULL) + sscanf(out,"%u",&MINN); + if ((out=check_option(in,n,'r','f')) != NULL) { + epsset=1; + sscanf(out,"%lf",&EPS0); + } + if ((out=check_option(in,n,'f','f')) != NULL) + sscanf(out,"%lf",&EPSF); + if ((out=check_option(in,n,'s','u')) != NULL) + sscanf(out,"%lu",&STEP); + if ((out=check_option(in,n,'C','u')) != NULL) { + sscanf(out,"%lu",&causal); + causalset=1; + } + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void make_fit(long act,unsigned long number,long istep,double **error) +{ + double casted,*help; + long i,j,h; + + h=istep-1; + for (j=0;j= ((long)LENGTH-(long)(embed*DELAY)-(long)MINN)) { + fprintf(stderr,"steps to forecast (-s) too large. Exiting!\n"); + exit(ZEROTH__STEP_TOO_LARGE); + } + if (!causalset) + causal=STEP; + +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,NULL,verbosity); + if (infile == NULL) + stdi=1; + + if (outfile == NULL) { + if (!stdi) { + check_alloc(outfile=(char*)calloc(strlen(infile)+5,(size_t)1)); + sprintf(outfile,"%s.zer",infile); + } + else { + check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1)); + sprintf(outfile,"stdin.zer"); + } + } + if (!stdo) + test_outfile(outfile); + + if (COLUMNS == NULL) + series=(double**)get_multi_series(infile,&LENGTH,exclude,&dim,"",dimset, + verbosity); + else + series=(double**)get_multi_series(infile,&LENGTH,exclude,&dim,COLUMNS, + dimset,verbosity); + + check_alloc(hser=(double**)malloc(sizeof(double*)*dim)); + check_alloc(av=(double*)malloc(sizeof(double)*dim)); + check_alloc(rms=(double*)malloc(sizeof(double)*dim)); + check_alloc(hinter=(double*)malloc(sizeof(double)*dim)); + interval=0.0; + for (i=0;i= MINN) { + for (j=1;j<=STEP;j++) { + make_fit(hi,actfound,j,error); + } + done[i]=1; + } + alldone &= done[i]; + } + } + if (stdo) { + if (verbosity&VER_INPUT) + fprintf(stderr,"Writing to stdout\n"); + for (i=0;i +#include +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Adds noise to a time series or just creates random numbers" + +char *outfile=NULL,cgaussian,stout=1,justcreate=0; +char *infile=NULL; +char absolute=0,dimset=0; +unsigned long length=ULONG_MAX,exclude=0,iseed=3441341; +unsigned int dim=1; +char *column=NULL; +unsigned int verbosity=0xff; +double **array,noiselevel=0.05; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [Options]\n\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of points to be used [Default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [Default: %lu]\n",exclude); + fprintf(stderr,"\t-m # of columns to read [Default: %u]\n",dim); + fprintf(stderr,"\t-c column(s) to read [Default: 1]\n"); + fprintf(stderr,"\t-%% noiselevel in %% [Default: %.1e%%]\n", + noiselevel*100.0); + fprintf(stderr,"\t-r absolute noise level (or absolute variance in case\n" + "\t\tof gaussian noise) [Default: not set]\n"); + fprintf(stderr,"\t-g (use gaussian noise) [Default: uniform]\n"); + fprintf(stderr,"\t-I seed for the rnd-generator (If seed=0, the time\n" + "\t\tcommand is used to set the seed) [Default: fixed]\n"); + fprintf(stderr,"\t-0 do not read input, just generate random numbers\n\t\t" + "(needs -l and -r) [Default: not set]\n"); + fprintf(stderr,"\t-o outfile [Without argument 'datafile'.noi;" + " Without -o stdout is used]\n"); + fprintf(stderr,"\t-V verbosity level [Default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr," -h show these options"); + fprintf(stderr,"\n"); + exit(0); +} + +void scan_options(int n,char** in) +{ + char *out,lengthset=0; + + if ((out=check_option(in,n,'l','u')) != NULL) { + sscanf(out,"%lu",&length); + lengthset=1; + } + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'m','u')) != NULL) { + sscanf(out,"%u",&dim); + dimset=1; + } + if ((out=check_option(in,n,'c','s')) != NULL) + column=out; + if ((out=check_option(in,n,'%','f')) != NULL) { + sscanf(out,"%lf",&noiselevel); + noiselevel /= 100.0; + } + if ((out=check_option(in,n,'r','f')) != NULL) { + sscanf(out,"%lf",&noiselevel); + absolute=1; + } + if ((out=check_option(in,n,'g','n')) != NULL) + cgaussian=1; + if ((out=check_option(in,n,'I','u')) != NULL) { + sscanf(out,"%lu",&iseed); + if (iseed == 0) + iseed=(unsigned long)time((time_t*)&iseed); + } + if ((out=check_option(in,n,'0','n')) != NULL) { + if (absolute && lengthset) + justcreate=1; + else { + fprintf(stderr,"\nThe -0 flag requires -l and -r\n\n"); + exit(MAKENOISE__FLAGS_REQUIRED); + } + } + + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'o','o')) != NULL) { + stout=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void equidistri(double sigmax,unsigned int which) +{ + int i; + double limit,equinorm; + + equinorm=(double)ULONG_MAX; + if (!absolute) + limit=2.0*sqrt(3.0)*sigmax*noiselevel; + else + limit=2.0*noiselevel; + for (i=0;i length; + */ +#include +#include +#include +#include +#include "routines/tsa.h" +#include + +#define WID_STR "Estimates the power spectrum of the data" + +#ifndef M_PI +#define M_PI 3.1415926535897932385E0 +#endif + +unsigned long poles=128,out=2000; +unsigned long length=ULONG_MAX,exclude=0; +unsigned int column=1; +unsigned int verbosity=0x1; +double samplingrate=1.0; +char *outfile=NULL,stdo=1; +char *infile=NULL; +double *series; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [Options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l length of file [default is whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default is 0]\n"); + fprintf(stderr,"\t-c column to read [default is 1]\n"); + fprintf(stderr,"\t-p number of poles [default is 128 or file length]\n"); + fprintf(stderr,"\t-P number of frequences out [default is 2000]\n"); + fprintf(stderr,"\t-f sampling rate in Hz [default is 1]\n"); + fprintf(stderr,"\t-o outfile [default is 'datafile'.spec]\n"); + fprintf(stderr,"\t-V verbosity level [default is 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n\t\t" + "2='+ print the ar coefficients too'\n"); + fprintf(stderr,"\t-h show these options\n\n"); + exit(0); +} + +void scan_options(int argc,char **argv) +{ + char *hout; + + if ((hout=check_option(argv,argc,'l','u')) != NULL) + sscanf(hout,"%lu",&length); + if ((hout=check_option(argv,argc,'x','u')) != NULL) + sscanf(hout,"%lu",&exclude); + if ((hout=check_option(argv,argc,'c','u')) != NULL) + sscanf(hout,"%u",&column); + if ((hout=check_option(argv,argc,'p','u')) != NULL) + sscanf(hout,"%lu",&poles); + if ((hout=check_option(argv,argc,'P','u')) != NULL) + sscanf(hout,"%lu",&out); + if ((hout=check_option(argv,argc,'f','f')) != NULL) + sscanf(hout,"%lf",&samplingrate); + if ((hout=check_option(argv,argc,'V','u')) != NULL) + sscanf(hout,"%u",&verbosity); + if ((hout=check_option(argv,argc,'o','o')) != NULL) { + stdo=0; + if (strlen(hout) > 0) + outfile=hout; + } +} + +double getcoefs(double *coef) +{ + long i,j,hp=(long)poles-1; + double ret=0.0,*cov,*help,h1,h2; + + check_alloc(cov=(double*)malloc(sizeof(double)*length)); + check_alloc(help=(double*)malloc(sizeof(double)*poles)); + + for (i=0;i +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Estimates the time delayed mutual information\n\t\ +of the data set" + + +char *file_out=NULL,stout=1; +char *infile=NULL; +unsigned long length=ULONG_MAX,exclude=0; +unsigned int column=1; +unsigned int verbosity=0xff; +long partitions=16,corrlength=20; +long *array,*h1,*h11,**h2; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [Options]\n\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of points to be used [Default is all]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [Default is 0]\n"); + fprintf(stderr,"\t-c column to read [Default is 1]\n"); + fprintf(stderr,"\t-b # of boxes [Default is 16]\n"); + fprintf(stderr,"\t-D max. time delay [Default is 20]\n"); + fprintf(stderr,"\t-o output file [-o without name means 'datafile'.mut;" + "\n\t\tNo -o means write to stdout]\n"); + fprintf(stderr,"\t-V verbosity level [Default is 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + fprintf(stderr,"\n"); + exit(0); +} + +void scan_options(int n,char** in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','u')) != NULL) + sscanf(out,"%u",&column); + if ((out=check_option(in,n,'b','u')) != NULL) + sscanf(out,"%lu",&partitions); + if ((out=check_option(in,n,'D','u')) != NULL) + sscanf(out,"%lu",&corrlength); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'o','o')) != NULL) { + stout=0; + if (strlen(out) > 0) + file_out=out; + } +} + +double make_cond_entropy(long t) +{ + long i,j,hi,hii,count=0; + double hpi,hpj,pij,cond_ent=0.0,norm; + + for (i=0;i= t) { + hii=array[i]; + hi=array[i-t]; + h1[hi]++; + h11[hii]++; + h2[hi][hii]++; + count++; + } + + norm=1.0/(double)count; + cond_ent=0.0; + + for (i=0;i 0.0) { + for (j=0;j 0.0) { + pij=(double)h2[i][j]*norm; + if (pij > 0.0) + cond_ent += pij*log(pij/hpj/hpi); + } + } + } + } + + return cond_ent; +} + +int main(int argc,char** argv) +{ + char stdi=0; + long tau,i; + double *series,min,interval,shannon; + FILE *file; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,&column,verbosity); + if (infile == NULL) + stdi=1; + + if (file_out == NULL) { + if (!stdi) { + check_alloc(file_out=(char*)calloc(strlen(infile)+5,(size_t)1)); + strcpy(file_out,infile); + strcat(file_out,".mut"); + } + else { + check_alloc(file_out=(char*)calloc((size_t)10,(size_t)1)); + strcpy(file_out,"stdin.mut"); + } + } + if (!stout) + test_outfile(file_out); + + series=(double*)get_series(infile,&length,exclude,column,verbosity); + rescale_data(series,length,&min,&interval); + + check_alloc(h1=(long *)malloc(sizeof(long)*partitions)); + check_alloc(h11=(long *)malloc(sizeof(long)*partitions)); + check_alloc(h2=(long **)malloc(sizeof(long *)*partitions)); + for (i=0;i= length) + corrlength=length-1; + + if (!stout) { + file=fopen(file_out,"w"); + if (verbosity&VER_INPUT) + fprintf(stderr,"Opened %s for writing\n",file_out); + fprintf(file,"#shannon= %e\n",shannon); + fprintf(file,"%d %e\n",0,shannon); + for (tau=1;tau<=corrlength;tau++) { + fprintf(file,"%ld %e\n",tau,make_cond_entropy(tau)); + fflush(file); + } + fclose(file); + } + else { + if (verbosity&VER_INPUT) + fprintf(stderr,"Writing to stdout\n"); + fprintf(stdout,"#shannon= %e\n",shannon); + fprintf(stdout,"%d %e\n",0,shannon); + for (tau=1;tau<=corrlength;tau++) { + fprintf(stdout,"%ld %e\n",tau,make_cond_entropy(tau)); + fflush(stdout); + } + } + + return 0; +} + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/new.tgz b/binaries/src/disembl/Tisean_3.0.1/source_c/new.tgz new file mode 100644 index 0000000000000000000000000000000000000000..69194de213ac0f83c2dde54dc1ffc3fb22691dd0 GIT binary patch literal 5609 zcmVFMd`JQ@=ud=|83@gSTY^}qWz zr48lDX`4QuJ~^dN?^JxY+o$c*&dGOP`{e1#$?3_H&JW+gL#X?XwZ9QPR#~K3kTCY$ zI2?__WF1_Xq-*eq!L;?~|B-U+oG-F*oIGb&0gu9j{Y-pt*=3Ms4D^Bzc{q5^ehTl{ z6PI;BlFT`-9XqeaK{N`}=QT#pPQ^0-kcBv;K4$nF z>yt3$gGC6OiW5XG`7jVD8$ib*O8F>)nrR%3*ffkr+1P)7`S#7f^7kEe@SBz}N|Vju!YNy7|~CW}Z27rqDRoTysi;gLpjRvW~NyJ^TA z2TYTP=~+$J%pQ6HP!Wv6vjT5|1bPC*vj9E|bUO~1z#v=#qWhQ+SUQeB_2PL3ik#L( z|MMgsMZqj=)czZE_R~1Xdb~G?>#E+Bn$S3d$HO@&S~jf15W^&K_u2atD0`|L3G1D@#z$v;3&gno`j%0 z`?WpB_E`Yx%I0yJa$uaSL*+y^AAO9vLqMu47*9!IBZj6H;m;%t21o4Q!HcpM3#Mr- zam>OXN(I;|!aruMsnk^#4;gjv0Sqbt+d6Qjl6Y@`b?-X^@?n;o4Q9wN3KS@4$+*&3H-oO@Q7zTn1aV>fhVyL zK3)i2L5o|3>0OTL{L1aRug@#cxb%;Zp{S%?ORH8ky{d<<;5Hei^h2neRg|I^S%oGw zIK>E^+P!0E?}(O3kB$@~23@P5$AGCoHDX+hjg|rr@?JWCdjbtoo&mEchJYl#y*4(f}WK3 zIgsw>!1OTP@KKJsbczgBLiv8#J4$e=$S+Fu47|Z+-Je%lOgq zZpqo1lS0Q4BnC;3=7v=S3NQt6R;HaO7n}{I)3{$(uzuY}(wK?oDgS#I5ABByr_&IQ zT(AJf{i1Wm)flVL<6sL&YI}RD`)D{cJuY=awbYfAy6&J&4CTjUv}g7+Pdt09pP{0` z+;fpc2D4W38!TV4ys!>QU8@2d#0q(63}=O>jOPCpf^vDAWJS+?;A7fE^bV~Riagfn zznK(u4__ll7(s;~Q>P@#ycZ=+06Qx^RN|Bm$!oNIh0*Q@n6{~(CU4*R0Mq2h0A1Z3 z!SKiO`RAIcKZbDi{3OiOvM=praqsV85*zj^7l*JaM{H8y6Z~!yUm%=T@#vbQr{K4) zTqhso%S^0207&U!3EKp)OUWw z#0P$0XpoEssjBqyO34@wj3FeG90_9+6V2pS&C4bxqP!Y7Ab9AvkJ_q|@JBw84bdTb zp#w#P0@%}ySku>n0N)?AczP@M5k5?)Vv?4-Vveu5ryfkmE;NWadCc{dMMlAp_aS5-pYuLJ_PKjSR8i2tf`_ zPs>FM%IwAziD@`u3vNDrkW4S~mMmy3qb>GM48}T9_zBUK!n&;YWhcczAldB@@{RnK z$jY1)enp#)ol!qQb7p~StJhE6%M0e<3c)rymwPVnxRGn=kt6$Yo%B;Mcfph&@T{Oh zwIra{u4?syNtxJ8XnKv3mI)QAo}o$fG&|c$e+%RZx;Im|QTqiVq{BKi5gL(CSmZLW zDc0IvyY04@r>7^KAEZp7Degel^IEG*XwWuP2cS_-^|h249!oINa9N6dGJ>ixNOzSR zaU0B6l5Se>I*V1Psn1(53WXlcLyW&*ydKi-3F1APD~S3I)^{ZFyhBea@S_dprt3LE zpLpliu|Qj13+e#Cm?wyZGwog$7T47)+C8<)g-u|AAF_S7M33IpvVrscF41#1O~dt_ z$>y87QD9~VVuJuo)K~4=<}^@fOToNy*5YDAeQhd!*#!8ATrUmQ80|0#L&I8y#u{~{ zU~KC!LTdHQ8;hz&+5d^v$#3?8Tll-;`gH=nQpVl?t*)@MbB3Fpq4A5>$VKtlu%FYz&9TX-;((`Qass-k3 z;Z^z9d(~oR>%1!ef8JZ!uvLr-29HwCg%lXli{~AvD zIF1Ky!25FYL%ZpC;x-Pa^E!>5hAoc{%-jU52Q6sGmex64-tesUh!4TshV1R@?oIEn zKcC<9y1gIY%D(j3!@(~XSH13=ckgdRS9z9$?8iuQcoar3K04izu9lGY- zyTpR>0f%VEeCu2U<>~3;LwR_hVbq2MJo+9%bHg^{i8^wi%nhf}m(fI=Pl#R{%~O}+ zOD}794Q+J*)1N;m1g?ZNp9YzJx_=ZTYpj1WMT&rDTadC(2^EDN)%gwbA{GqH!Zhp2 zMyhc`^HZE%6F!GV2uydJHZ&{xIQP5xe=|rPDxH2dB5}} zhz|CJWAAQ8l%$wLk%kedV-~Y942R9)BxC|hHVz_682FxDEIFnb!q2aIuiyT7 zaoM|h`?mM`{LO#%-o3rNxNfMuq#6_1R3a>>Qveasef!X?ER!v^$&9loOPWEpd6Ky4 z9IG^c6&q$-lT@IIqQMtTU1c!wt-XDWGophPaZ^g$+A79qBy!rgl%1F^;f%3*15^bv z-Lj!$y*VTbTfcoWUPQSClcjD8F3)FvabptWstCV|d^LA~A#FUm6q5{+wmPh#DU0BW zs{LHcA&q&B0HO*c+85aKc&+jkRA(Z@`^M>L^|7DCAE?7VlQL1+Fel%Y^LheS!Z#66 zol*`%9Lw!QOqmjm67^VZc3;B$MZ041$Q7JPU8aOIRVIjXEJfFnpAV}f5<7Q93P>h; zmPS7=#i14B@8n9p&MGUhf04GY!6H^3fE^Bm?H9<;{ry;AYVy_}lQ9}w{w3>MLR!l2hBd$_N03S3ut-5g7Nf*IzCo9RF`Krg3Lylb5_7y ztH0%lX~jmREkj|Z>;?|TNSf+( z@2K5GLOMsz>)yL=Ls+Y^uoCs-^MvWAtewTpD8Ld!F#kWkwSl^2|(0u9|P5 zVdWB08S?D$bbwolO;7t4+oPf3Sprz*VI7;4WndcN+DwHNxgjgEL!_%1fTKX2GzPQm zJzmtK*5gG3M>1%7E>ATrB+MK(EW)-Zu%uP9pPU621B`v;wHvOA1zdg|ni#z9^_wh^G+RR!QiO3UGztZ4u@QExs<; zRWPP1IZ1ZKL#+d&y_nW9Uup1d`dEMeNBf7 zXBy8!_Cvdk&8MjgZTs*IPe{l3YS45+(=EJKM2>_O0KMz(e_b%I-8m(i@U>!fX9B%( zo+=6puaKuECcT_s?WJecVhn}KPO-8Bm8ZqZ6R7-`V&y5~Y!_>PK%}MGCy3Rq{i%C( zebc)HVIlH14f1`|k7u(m$|P$N9^i1Zn2o}WC3v~SP_kcKTJVdw^F_VqF0P4Dz1S%y zq(bru?vpMXut-=o9QbRHu8^wq`uHk4{?)=Igt>_AzuJcoqO?O+QX-E|l!0HACFD5Z z*(HQZ<-tq?nPVUliCjB>vhW+T3`D54vWBd;AIhCLrF@2M`-0x=`$%NE6Md}cmGVwu z=G_mbA!Xg@gwq0kU9G+paOl_EzOp@S!{5dED{A6BB}aW$40k0{?H_VYsk^iJ2s$+A zMIj%J?_fQ*vUgptGe>NCR(D@+kP}suX-*`mAS-4=VN3DIu{v>9NLOI7-pQ7&5tIBY z2m)N(6kJcJ4~X2dM9ZzLj3JSqRM2e4DZIs|@mHg@StFBpdUOK~_}RM6{`@~9v&RA{ zC{U&P39B=ea0@M5XWeB@sMdqE#B}~VYAQ@ckX1IAl@=pSW^b*{a~CnkU#^(a`t zOe%=#T6xQ30BsGU@*tqv%iWL>rj+&;y#zE+)~G?OcG#e5{_$B)I^^e{J#YWLieCR& z8u|NP1-W7U2g|-Edj0nl;k+j&-jm(>?~f>3uKğuF9%&%^=FMt%VVj+RBuVA&6 z;kpdwMt@uAtz%F=F!N|JyMuP@6VJx5a=YVM5+n}{H8SCMi%i@o*`?*)yC4Z>VA<(& zw)E`_uxMd{3q`tV(QaHS(b6|ABU@I2^nFQM1+B0i>eHAiTi%&1?|39mib`~mXNMJV zhU%Ei~0d{vl{WVI7&Va_ZxwG=N8)BUk z-Iel#p=W)%2KX?;$txz-M@w_RcZEUUK~#YwQX-pD`l7x}#-rVHVd=iQAB%n$_}V~wsn_xU zUgk6ogkspQCaStEUra2pxNor-0R0^JF{+7iFe*-CfHmeDi!c(wM-&GlXw>%Zz!&~1 z8lsLWwls3oT37Y`w2qLRXeIeciGe(7>J#RPglZz%hC}+P4=-phA84^Q^ChN#x-I=( z*_B<{m0j7DUD=gg*_B<{m0j7DUD=gg*_B<{m0j7DUD=gg*_B=SCoTU2(Yzp10C)fZ D3(gm; literal 0 HcmV?d00001 diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/nrlazy.c b/binaries/src/disembl/Tisean_3.0.1/source_c/nrlazy.c new file mode 100644 index 0000000..2eda076 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/nrlazy.c @@ -0,0 +1,383 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger Last modified: Nov 30, 2000 */ +/*Changes: + 12/11/05: Going multivariate +*/ + +#include +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Performs simple noise reduction." + +#define BOX (unsigned int)512 + +unsigned long length=ULONG_MAX,exclude=0; +unsigned int comp=1,embed=5,delay=1,iterations=1,alldim; +unsigned int verbosity=0x3; +char *column=NULL; +double eps=1.0e-3,epsvar; + +char *outfile=NULL,epsset=0,stdo=1,epsvarset=0; +char *infile=NULL; +double **series,**corr,*interval,*min,*hcor; +long **box,*list,**nf; +unsigned int **indexes; +char dimset=0; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [Options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default: 0]\n"); + fprintf(stderr,"\t-c column to read [default: 1]\n"); + fprintf(stderr,"\t-m no. of comp.,embedding dim. [default: %u,%u]\n", + comp,embed); + fprintf(stderr,"\t-d delay [default: 1]\n"); + fprintf(stderr,"\t-i iterations [default: 1]\n"); + fprintf(stderr,"\t-r neighborhoud size [default: (interval of data)/1000]\n"); + fprintf(stderr,"\t-v neighborhoud size (in units of the std. dev. of the " + "data \n\t\t(overwrites -r) [default: not set]\n"); + fprintf(stderr,"\t-o output file name [Default: 'datafile'.laz.n," + "\n\t\twhere n is the number of the last iteration," + "\n\t\twithout -o the last iteration is written to stdout.]\n"); + fprintf(stderr,"\t-V verbosity level [Default: 3]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n\t\t" + "2='+ write output of all iterations to files'\n\t\t" + "4='+ write the number of neighbors found for each point\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','c')) != NULL) { + column=out; + dimset=1; + } + if ((out=check_option(in,n,'m','2')) != NULL) + sscanf(out,"%u,%u",&comp,&embed); + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&delay); + if ((out=check_option(in,n,'i','u')) != NULL) + sscanf(out,"%u",&iterations); + if ((out=check_option(in,n,'r','f')) != NULL) { + epsset=1; + sscanf(out,"%lf",&eps); + } + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'v','f')) != NULL) { + epsvarset=1; + sscanf(out,"%lf",&epsvar); + } + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +unsigned int correct(unsigned long n) +{ + int i,i1,i2,j,j1,k; + int ibox=BOX-1; + unsigned int hdel,hcomp; + double epsinv,dx; + long element,nfound=0; + + epsinv=1./eps; + + for (i=0;i eps) + break; + } + if (k == alldim) { + nfound++; + for (k=0;k maxinterval) maxinterval=interval[i]; + variance(series[i],length,&dav,&dvar); + if (dvar > maxdvar) maxdvar=dvar; + } + alldim=comp*embed; + + check_alloc(nmf=(unsigned int*)malloc(sizeof(int)*length)); + check_alloc(list=(long*)malloc(sizeof(long)*length)); + check_alloc(box=(long**)malloc(sizeof(long*)*BOX)); + for (n=0;n +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Tests for nonstationarity by means of the average\n\t\ +forecast error for a zeroth order fit" + + +#ifndef _MATH_H +#include +#endif + +/*number of boxes for the neighbor search algorithm*/ +#define NMAX 128 + +unsigned int nmax=(NMAX-1); +long **box,*list; +unsigned long *found; +double *series,*series1,*series2; +double interval,min,epsilon; + +char epsset=0,causalset=0; +char *infile=NULL; +char *outfile=NULL,stdo=1,centerset=0; +char *firstwindow,*secondwindow,**window; +unsigned int COLUMN=1,pieces; +unsigned int verbosity=0xff; +int DIM=3,DELAY=1,MINN=30,STEP=1; +int firstoffset= -1,secondoffset= -1; +double EPS0=1.e-3,EPSF=1.2; +unsigned long LENGTH=ULONG_MAX,exclude=0,center,causal; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s -# [other options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default: 0]\n"); + fprintf(stderr,"\t-c column to read [default: 1]\n"); + fprintf(stderr,"\t-m embedding dimension [default: 3]\n"); + fprintf(stderr,"\t-d delay [default: 1]\n"); + fprintf(stderr,"\t-# # of pieces [no default]\n"); + fprintf(stderr,"\t-1 which pieces for the first window " + "[default: 1-pieces]\n"); + fprintf(stderr,"\t-2 which pieces for the second window " + "[default: 1-pieces]\n"); + fprintf(stderr,"\t-n # of reference points in the window [default: all]\n"); + fprintf(stderr,"\t-k minimal number of neighbors for the fit " + "[default: 30]\n"); + fprintf(stderr,"\t-r neighborhoud size to start with " + "[default: (data interval)/1000]\n"); + fprintf(stderr,"\t-f factor to increase size [default: 1.2]\n"); + fprintf(stderr,"\t-s steps to forecast [default: 1]\n"); + fprintf(stderr,"\t-C width of causality window [default: steps]\n"); + fprintf(stderr,"\t-o output file [default: 'datafile.nsz'," + " without -o: stdout]\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + fprintf(stderr,"\n\t The -# option has to be set\n"); + exit(0); +} + +void parse_minus(char *str,char *array,char *wopt) +{ + int cm=0,i,strl,n1,n2; + + strl=strlen(str); + for (i=0;i 1) { + fprintf(stderr,"Invalid string for the %s option! " + "Please consult the help-page\n",wopt); + exit(NSTAT_Z__INVALID_STRING_FOR_OPTION); + } + if (cm == 0) { + sscanf(str,"%d",&n1); + n1--; + if (n1 < 0) { + fprintf(stderr,"Numbers in %s option must be larger than 0!\n",wopt); + exit(NSTAT_Z__NOT_UNSIGNED_FOR_OPTION); + } + if (n1 >= pieces) { + fprintf(stderr,"Numbers in %s option must be smaller than %u!\n",wopt, + pieces); + exit(NSTAT_Z__TOO_LARGE_FOR_OPTION); + } + array[n1]=1; + } + else { + sscanf(str,"%d-%d",&n1,&n2); + n1--; + n2--; + if ((n1 < 0) || (n2 < 0)) { + fprintf(stderr,"Numbers in %s option must be larger than 0!\n",wopt); + exit(NSTAT_Z__NOT_UNSIGNED_FOR_OPTION); + } + if ((n1 >= pieces) || (n2 >= pieces)) { + fprintf(stderr,"Numbers in %s option must be smaller than %u!\n",wopt, + pieces+1); + exit(NSTAT_Z__TOO_LARGE_FOR_OPTION); + } + if (n2 < n1) { + i=n1; + n1=n2; + n2=i; + } + for (i=n1;i<=n2;i++) + array[i]=1; + } +} + +void parse_comma(char *str,char *array,char *wopt) +{ + unsigned int strl,i,cp=1,which,iwhich; + char **hstr; + + strl=strlen(str); + for (i=0;i 0) + outfile=out; + } +} + +double make_fit(long act,unsigned long number) +{ + double casted=0.0,*help; + int i; + + help=series1+STEP; + for (i=0;i= 0) && (first < pieces)) + window[first][second]=secondwindow[second]; + } + if (secondoffset != -1) { + for (first=0;first= 0) && (second < pieces)) + window[first][second]=firstwindow[first]; + } + + free(firstwindow); + free(secondwindow); + + for (first=0;first= MINN) { + error += make_fit(i,actfound); + done[i]=1; + } + alldone &= done[i]; + } + } + if (stdo) + fprintf(stdout,"%ld %ld %e\n",first+1,second+1, + sqrt(error/center)/rms[second]); + else { + fprintf(file,"%ld %ld %e\n",first+1,second+1, + sqrt(error/center)/rms[second]); + fflush(file); + } + } + } + if (sdone) { + if (stdo) + fprintf(stdout,"\n"); + else + fprintf(file,"\n"); + } + } + + if (!stdo) + fclose(file); + + if (outfile != NULL) + free(outfile); + free(list); + free(found); + free(hfound); + free(done); + for (i=0;i +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Performs a global PCA" + +unsigned long LENGTH=ULONG_MAX,exclude=0; +unsigned int DIM=2,EMB=1,dimemb,LDIM=2,DELAY=1; +unsigned int verbosity=0xff; +char *outfile=NULL,stout=1,dim_set=0; +unsigned int what_to_write=0,write_values=1,write_vectors=0; +unsigned int write_comp=0,write_proj=0; +unsigned int projection_set=0; +char *infile=NULL,dimset=0,*column=NULL; +double **series; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [Default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignore [Default: 0]\n"); + fprintf(stderr,"\t-c columns to read [Default: 2]\n"); + fprintf(stderr,"\t-m columns,embedding dim. to use [Default: 2,1]\n"); + fprintf(stderr,"\t-d delay to use [Default: 1]\n"); + fprintf(stderr,"\t-q projection dimension [Default: no projection]\n"); + fprintf(stderr,"\t-W # what to write: [Default: 0]\n" + "\t\t0 write eigenvalues only\n" + "\t\t1 write eigenvectors\n" + "\t\t2 write (projected) pca components\n" + "\t\t3 write projected data\n"); + fprintf(stderr,"\t-o output file name \n\t\t[Default: stdout; -o without " + "value means 'datafile'.pca]\n"); + fprintf(stderr,"\t-V verbosity level [Default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&LENGTH); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','s')) != NULL) + column=out; + if ((out=check_option(in,n,'m','2')) != NULL) { + sscanf(out,"%u,%u",&DIM,&EMB); + dimset=1; + } + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&DELAY); + if ((out=check_option(in,n,'q','u')) != NULL) { + sscanf(out,"%u",&LDIM); + projection_set=1; + } + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'W','u')) != NULL) { + sscanf(out,"%u",&what_to_write); + switch(what_to_write) { + case 0: write_values=1;break; + case 1: write_values=0;write_vectors=1;break; + case 2: write_values=0;write_comp=1;break; + case 3: write_values=0;write_proj=1;break; + default: { + fprintf(stderr,"Wrong value for the -W flag. Exiting!\n"); + exit(127); + } + } + } + if ((out=check_option(in,n,'o','o')) != NULL) { + stout=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void ordne(double *lyap,int *ord) +{ + long i,j,maxi; + double max; + + for (i=0;i dimemb) LDIM=dimemb; + } + + check_alloc(av=(double*)malloc(sizeof(double)*DIM)); + for (j=0;j +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Make a Poincare section" + +char *outfile=NULL,dimset=0,compset=0,whereset=0,stdo=1; +char *infile=NULL; +unsigned long length=ULONG_MAX,count,exclude=0; +int dim=2,comp=2,delay=1,dir=0; +unsigned int column=1; +unsigned int verbosity=0xff; +double *series,min,max,average=0.0,where; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [Options]\n\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of points to be used [Default: whole file]\n"); + fprintf(stderr,"\t-x #of lines to be ignored [Default: 0]\n"); + fprintf(stderr,"\t-c column to read [Default: 1]\n"); + fprintf(stderr,"\t-m embedding dimension [Default: 2]\n"); + fprintf(stderr,"\t-d delay [Default: 1]\n"); + fprintf(stderr,"\t-q component to cut [Default: last]\n"); + fprintf(stderr,"\t-C direction of the cut (0: from below,1: from above)" + "\n\t\t[Default: 0]\n"); + fprintf(stderr,"\t-a set crossing at [Default: average of data]\n"); + fprintf(stderr,"\t-o outfile [Default: 'datafile'.poin]\n"); + fprintf(stderr,"\t-V verbosity level [Default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + fprintf(stderr,"\n"); + exit(0); +} + + +void scan_options(int n,char** in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','u')) != NULL) + sscanf(out,"%u",&column); + if ((out=check_option(in,n,'m','u')) != NULL) { + dimset=1; + sscanf(out,"%u",&dim); + } + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&delay); + if ((out=check_option(in,n,'q','u')) != NULL) { + compset=1; + sscanf(out,"%u",&comp); + } + if ((out=check_option(in,n,'C','u')) != NULL) + sscanf(out,"%u",&dir); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'a','f')) != NULL) { + whereset=1; + sscanf(out,"%lf",&where); + } + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void poincare(void) +{ + unsigned long i; + long j,jd; + double delta,xcut; + double time=0.0,lasttime=0.0; + FILE *fout=NULL; + + if (!stdo) { + fout=fopen(outfile,"w"); + if (verbosity&VER_INPUT) + fprintf(stderr,"Opened %s for writing\n",outfile); + } + else { + if (verbosity&VER_INPUT) + fprintf(stderr,"Writing to stdout\n"); + } + + if (dir == 0) { + for (i=(comp-1)*delay;i= where)) { + delta=(series[i]-where)/(series[i]-series[i+1]); + time=(double)i+delta; + if (lasttime > 0.0) { + for (j= -(comp-1);j<=dim-comp;j++) { + if (j != 0) { + jd=i+j*delay; + xcut=series[jd]+delta*(series[jd+1]-series[jd]); + if (!stdo) + fprintf(fout,"%e ",xcut); + else + fprintf(stdout,"%e ",xcut); + } + } + if (!stdo) { + fprintf(fout,"%e\n",time-lasttime); + fflush(fout); + } + else { + fprintf(stdout,"%e\n",time-lasttime); + fflush(stdout); + } + count++; + } + lasttime=time; + } + } + } + else { + for (i=(comp-1)*delay;i where) && (series[i+1] <= where)) { + delta=(series[i]-where)/(series[i]-series[i+1]); + time=(double)i+delta; + if (lasttime > 0.0) { + for (j= -(comp-1);j<=dim-comp;j++) { + if (j != 0) { + jd=i+j*delay; + xcut=series[jd]+delta*(series[jd+1]-series[jd]); + if (!stdo) + fprintf(fout,"%e ",xcut); + else + fprintf(stdout,"%e ",xcut); + } + } + if (!stdo) { + fprintf(fout,"%e\n",time-lasttime); + fflush(fout); + } + else { + fprintf(stdout,"%e\n",time-lasttime); + fflush(stdout); + } + count++; + } + lasttime=time; + } + } + } + if (!stdo) + fclose(fout); +} + +int main(int argc,char** argv) +{ + char stdi=0; + long i; + double var; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,&column,verbosity); + if (infile == NULL) + stdi=1; + + if (outfile == NULL) { + if (!stdi) { + check_alloc(outfile=(char*)calloc(strlen(infile)+6,(size_t)1)); + strcpy(outfile,infile); + strcat(outfile,".poin"); + } + else { + check_alloc(outfile=(char*)calloc((size_t)11,(size_t)1)); + strcpy(outfile,"stdin.poin"); + } + } + if (!stdo) + test_outfile(outfile); + + series=(double*)get_series(infile,&length,exclude,column,verbosity); + variance(series,length,&average,&var); + min=max=series[0]; + for (i=1;i max) max=series[i]; + } + + if (!whereset) + where=average; + if (dimset && !compset) + comp=dim; + + if (comp > dim) { + fprintf(stderr,"Component to cut is larger than dimension. Exiting!\n"); + exit(POINCARE__WRONG_COMPONENT); + } + if ((where < min) || (where > max)) { + fprintf(stderr,"You want to cut outside the data interval which is [%e," + "%e]\n",min,max); + exit(POINCARE__OUTSIDE_REGION); + } + poincare(); + + return 0; +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/polyback.c b/binaries/src/disembl/Tisean_3.0.1/source_c/polyback.c new file mode 100644 index 0000000..ea5b10f --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/polyback.c @@ -0,0 +1,355 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger. Last modified Sep 4, 1999 */ +#include +#include +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Does a backward elimination for a polynomial" + +char *outfile=NULL,stdo=1; +char *parin=NULL,*infile=NULL; +unsigned long length=ULONG_MAX,insample=ULONG_MAX,exclude=0; +unsigned int plength=UINT_MAX; +unsigned int column=1,dim=2,delay=1,down_to=1,step=1; +unsigned int **order; +unsigned int verbosity=0xff; +double *series,*param; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr,"Usage: %s [Options]\n",progname); + fprintf(stderr,"Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to ignore [default: %lu]\n",exclude); + fprintf(stderr,"\t-c column to read [default: %u]\n",column); + fprintf(stderr,"\t-m embedding dimension [default: %u]\n",dim); + fprintf(stderr,"\t-d delay [default: %u]\n",delay); + fprintf(stderr,"\t-n insample data [default: all]\n"); + fprintf(stderr,"\t-s steps to forecast [default: %u]\n",step); + fprintf(stderr,"\t-# reduce down to # terms [default: %u]\n",down_to); + fprintf(stderr,"\t-p name of parameter file [default: parameter.pol]\n"); + fprintf(stderr,"\t-o output file name [default: 'datafile'.pbe]\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','u')) != NULL) + sscanf(out,"%u",&column); + if ((out=check_option(in,n,'m','u')) != NULL) + sscanf(out,"%u",&dim); + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&delay); + if ((out=check_option(in,n,'n','u')) != NULL) + sscanf(out,"%lu",&insample); + if ((out=check_option(in,n,'#','u')) != NULL) + sscanf(out,"%u",&down_to); + if ((out=check_option(in,n,'s','u')) != NULL) + sscanf(out,"%u",&step); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'p','s')) != NULL) + parin=out; + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +double polynom(unsigned long act,unsigned int which) +{ + unsigned int i,j; + double ret=1.0,h; + + for (i=0;i= length) { + insample=length; + out_set=0; + } + + check_alloc(order=(unsigned int**)malloc(sizeof(int*)*hlength)); + check_alloc(param=(double*)malloc(sizeof(double)*hlength)); + for (i=0;i hlength)) + down_to=1; + + for (i=1;i<=hlength-down_to;i++) { + plength=hlength-i; + besti=besto=0.0; + ibest= -1; + check_alloc(order=(unsigned int**)malloc(sizeof(int*)*plength)); + check_alloc(param=(double*)malloc(sizeof(double)*plength)); + for (j=0;j +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Fits a polynomial to the data" + +char CAST=0,sinsample=0,*outfile=NULL; +char *infile=NULL; +unsigned long LENGTH=ULONG_MAX,exclude=0; +long CLENGTH=1000; +unsigned long INSAMPLE=ULONG_MAX; +int DIM=2,DELAY=1,N=2; +unsigned int COLUMN=1; +unsigned int pars=1,hpar; +unsigned int verbosity=0xff; + +long *coding; +long maxencode; +double *series,*results; +double std_dev; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default: 0]\n"); + fprintf(stderr,"\t-c column to read [default: 1]\n"); + fprintf(stderr,"\t-m embedding dimension [default: 2]\n"); + fprintf(stderr,"\t-d delay [default: 1]\n"); + fprintf(stderr,"\t-p order of the polynomial [default: 2]\n"); + fprintf(stderr,"\t-n # of points for insample [default: # of data]\n"); + fprintf(stderr,"\t-L steps to cast [default: none]\n"); + fprintf(stderr,"\t-o output file name [default: 'datafile'.pol]\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&LENGTH); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','u')) != NULL) + sscanf(out,"%u",&COLUMN); + if ((out=check_option(in,n,'m','u')) != NULL) + sscanf(out,"%u",&DIM); + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&DELAY); + if ((out=check_option(in,n,'p','u')) != NULL) + sscanf(out,"%u",&N); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'n','u')) != NULL) { + sscanf(out,"%lu",&INSAMPLE); + sinsample=1; + } + if ((out=check_option(in,n,'L','u')) != NULL) { + CAST=1; + sscanf(out,"%lu",&CLENGTH); + } + if ((out=check_option(in,n,'o','o')) != NULL) + if (strlen(out) > 0) + outfile=out; +} + +double polynom(int act,int dim,long cur,long fac) +{ + int j,n,hi; + double ret=1.0; + + n=cur/fac; + hi=act-(dim-1)*DELAY; + for (j=1;j<=n;j++) + ret *= series[hi]; + if (dim > 1) + ret *= polynom(act,dim-1,cur-n*fac,fac/(N+1)); + + return ret; +} + +int number_pars(int ord,int start) +{ + int i,ret=0; + + if (ord == 1) + for (i=start;i<=DIM;i++) + ret += 1; + else + for (i=start;i<=DIM;i++) + ret += number_pars(ord-1,i); + + return ret; +} + +void make_coding(int ord,int d,int fac,int cur) +{ + int j; + + if ( d == -1) + coding[hpar++]=cur; + else + for (j=0;j<=ord;j++) + make_coding(ord-j,d-1,fac*(N+1),cur+j*fac); +} + +void make_fit(void) +{ + int i,j,k; + double **mat,*b; + + check_alloc(b=(double*)malloc(sizeof(double)*pars)); + check_alloc(mat=(double**)malloc(sizeof(double*)*pars)); + for (i=0;i 0) + decode(out,dim-1,cur-(long)n*fac,fac/(N+1)); +} + +double make_error(unsigned long i0,unsigned long i1) +{ + int j,k; + double h,err; + + err=0.0; + for (j=i0+(DIM-1)*DELAY;j<(long)i1-1;j++) { + h=0.0; + for (k=0;k LENGTH)) + INSAMPLE=LENGTH; + + maxencode=1; + for (i=1;i +#include +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Fits a polynomial to the data." + +char *outfile=NULL,stdo=1; +char *parin=NULL,*infile=NULL; +unsigned long length=ULONG_MAX,insample=ULONG_MAX,exclude=0; +unsigned long plength=UINT_MAX; +unsigned long step=1000; +unsigned int column=1,dim=2,delay=1,down_to=1; +unsigned int **order; +unsigned int verbosity=0xff; +double *series,*param; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr,"Usage: %s [Options]\n",progname); + fprintf(stderr,"Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to ignore [default: %lu]\n",exclude); + fprintf(stderr,"\t-c column to read [default: %u]\n",column); + fprintf(stderr,"\t-m embedding dimension [default: %u]\n",dim); + fprintf(stderr,"\t-d delay [default: %u]\n",delay); + fprintf(stderr,"\t-n insample data [default: all]\n"); + fprintf(stderr,"\t-L length of forecasted series [default: %lu]\n",step); + fprintf(stderr,"\t-p name of parameter file [default: parameter.pol]\n"); + fprintf(stderr,"\t-o output file name [default: 'datafile'.pbf]\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','u')) != NULL) + sscanf(out,"%u",&column); + if ((out=check_option(in,n,'m','u')) != NULL) + sscanf(out,"%u",&dim); + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&delay); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'n','u')) != NULL) + sscanf(out,"%lu",&insample); + if ((out=check_option(in,n,'L','u')) != NULL) + sscanf(out,"%lu",&step); + if ((out=check_option(in,n,'p','s')) != NULL) + parin=out; + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +double polynom(unsigned long act,unsigned int which) +{ + unsigned int i,j; + double ret=1.0,h; + + for (i=0;i= length) { + insample=length; + oose=0; + } + + check_alloc(param=(double*)malloc(sizeof(double)*plength)); + + make_fit(); + withalli=forecast_error(0LU,insample); + withallo=0.0; + if (oose) + withallo=forecast_error(insample+1,length); + + if (stdo) { + if (verbosity&VER_INPUT) + fprintf(stderr,"Writing to stdout\n"); + fprintf(stdout,"#FCE: %e %e\n",withalli/varianz,withallo/varianz); + for (i=0;i +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Creates a parameter file containing all terms\n\t\ +for a polynomial" + + +char *outfile=NULL; +unsigned int dim=2,order=3; +unsigned int verbosity=0xff; +FILE *file=NULL; + +void make_parameter(unsigned int*,unsigned int, unsigned int); + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [Options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"\t-m embedding dimension [Default: %u]\n",dim); + fprintf(stderr,"\t-p order of the polynomial [Default: %u]\n",order); + fprintf(stderr,"\t-o parameter file [Default: parameter.pol]\n"); + fprintf(stderr,"\t-V verbosity level [Default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'m','u')) != NULL) + sscanf(out,"%u",&dim); + if ((out=check_option(in,n,'p','u')) != NULL) + sscanf(out,"%u",&order); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'o','o')) != NULL) { + if (strlen(out) > 0) + outfile=out; + } +} + +void make_parameter(unsigned int *par,unsigned int d,unsigned int sum) +{ + int i,j; + + for (i=0;i<=order;i++) { + sum += i; + if (sum <= order) { + par[d]=i; + if (d == 0) { + for (j=0;j +#include +#include +#include +#include "routines/tsa.h" +#include + +#define WID_STR "Fits a RBF-model to the data" + +char *outfile=NULL,stdo=1,MAKECAST=0; +char *infile=NULL; +char setdrift=1; +int DIM=2,DELAY=1,CENTER=10,STEP=1; +unsigned int COLUMN=1; +unsigned int verbosity=0xff; +long CLENGTH=1000; +unsigned long LENGTH=ULONG_MAX,INSAMPLE=ULONG_MAX,exclude=0; + +double *series,*coefs; +double varianz,interval,min; +double **center; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [default: all from file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default: 0]\n"); + fprintf(stderr,"\t-c column to read [default: %u]\n",COLUMN); + fprintf(stderr,"\t-m embedding dimension [default: %d]\n",DIM); + fprintf(stderr,"\t-d delay [default: %d]\n",DELAY); + fprintf(stderr,"\t-p number of centers [default: %d]\n",CENTER); + fprintf(stderr,"\t-X deactivate drift [default: activated]\n"); + fprintf(stderr,"\t-s steps to forecast [default: %d]\n",STEP); + fprintf(stderr,"\t-n # of points for insample [default: # of data]\n"); + fprintf(stderr,"\t-L steps to cast [default: none]\n"); + fprintf(stderr,"\t-o output file name [default: 'datafile'.rbf]\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&LENGTH); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','u')) != NULL) + sscanf(out,"%u",&COLUMN); + if ((out=check_option(in,n,'m','u')) != NULL) + sscanf(out,"%u",&DIM); + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&DELAY); + if ((out=check_option(in,n,'p','u')) != NULL) + sscanf(out,"%u",&CENTER); + if ((out=check_option(in,n,'X','n')) != NULL) + setdrift=0; + if ((out=check_option(in,n,'s','u')) != NULL) + sscanf(out,"%u",&STEP); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'n','u')) != NULL) + sscanf(out,"%lu",&INSAMPLE); + if ((out=check_option(in,n,'L','u')) != NULL) { + MAKECAST=1; + sscanf(out,"%lu",&CLENGTH); + } + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +double avdistance(void) +{ + int i,j,k; + double dist=0.0; + + for (i=0;i -0.1) && ((center[i][j]+h1) < 1.1)) + center[i][j] += h1; + } + } + } + free(force); +} + +void make_fit(void) +{ + double **mat,*hcen; + double h; + int i,j,n,nst; + + check_alloc(mat=(double**)malloc(sizeof(double*)*(CENTER+1))); + for (i=0;i<=CENTER;i++) + check_alloc(mat[i]=(double*)malloc(sizeof(double)*(CENTER+1))); + check_alloc(hcen=(double*)malloc(sizeof(double)*CENTER)); + + for (i=0;i<=CENTER;i++) { + coefs[i]=0.0; + for (j=0;j<=CENTER;j++) + mat[i][j]=0.0; + } + + for (n=(DIM-1)*DELAY;n LENGTH) + INSAMPLE=LENGTH; + + if (CENTER > LENGTH) + CENTER = LENGTH; + + if (MAKECAST) + STEP=1; + + check_alloc(coefs=(double*)malloc(sizeof(double)*(CENTER+1))); + check_alloc(center=(double**)malloc(sizeof(double*)*CENTER)); + for (i=0;iN-1 now 1->N + */ +#include +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "This programs makes a recurrence plot for the data." + +#define BOX 1024 + +unsigned long length=ULONG_MAX,exclude=0; +unsigned int embed=2,dim=1,delay=1; +unsigned int verbosity=0xff; +double eps=1.e-3,fraction=1.0; +char dimset=0; +char *columns; +char *outfile=NULL,stdo=1; +char *infile=NULL; +char epsset=0; + +double **series; +long **box,*list; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr,"Usage: %s [options]\n",progname); + fprintf(stderr,"Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [Default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [Default: 0]\n"); + fprintf(stderr,"\t-c columns to read [Default: 1]\n"); + fprintf(stderr,"\t-m # of components,embedding dimension [Default: 1,2]\n"); + fprintf(stderr,"\t-d delay [Default: 1]\n"); + fprintf(stderr,"\t-r size of the neighbourhood " + "[Default: (data interval)/1000]\n"); + fprintf(stderr,"\t-%% print only a percentage of points found [Default: " + " 100.0]\n"); + fprintf(stderr,"\t-o output file name [Default: 'datafile'.rec\n" + "\t\twithout -o: stdout]\n"); + fprintf(stderr,"\t-V verbosity level [Default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','s')) != NULL) + columns=out; + if ((out=check_option(in,n,'m','2')) != NULL) { + sscanf(out,"%u,%u",&dim,&embed); + dimset=1; + } + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&delay); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'r','f')) != NULL) { + epsset=1; + sscanf(out,"%lf",&eps); + } + if ((out=check_option(in,n,'%','f')) != NULL) { + sscanf(out,"%lf",&fraction); + fraction /= 100.0; + } + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +void lfind_neighbors(void) +{ + int i,i1,i2,j,j1,ke,ked,kd; + int ibox=BOX-1; + long n,element; + double dx,epsinv; + char toolarge; + FILE *fout=NULL; + + epsinv=1./eps; + rnd_init(0x9834725L); + + if (!stdo) { + fout=fopen(outfile,"w"); + if (verbosity&VER_INPUT) + fprintf(stderr,"Opened %s for writing\n",outfile); + } + else { + if (verbosity&VER_INPUT) + fprintf(stderr,"Writing to stdout\n"); + } + + for (n=(embed-1)*delay;n n) { + toolarge=0; + for (ke=0;ke= eps) { + toolarge=1; + break; + } + } + if (toolarge) + break; + } + if (!toolarge) + if (((double)rnd69069()/ULONG_MAX) <= fraction) { + if (!stdo) + fprintf(fout,"%ld %ld\n",n+1,element+1); + else + fprintf(stdout,"%ld %ld\n",n+1,element+1); + } + element=list[element]; + } + } + } + } + if (!stdo) + fclose(fout); +} + +int main(int argc,char **argv) +{ + long i; + char stdi=0; + double min,max,maxmax; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,NULL,verbosity); + if (infile == NULL) + stdi=1; + + if (outfile == NULL) { + if (!stdi) { + check_alloc(outfile=(char*)calloc(strlen(infile)+5,(size_t)1)); + strcpy(outfile,infile); + strcat(outfile,".rec"); + } + else { + check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1)); + strcpy(outfile,"stdin.rec"); + } + } + if (!stdo) + test_outfile(outfile); + + if (columns == NULL) + series=(double**)get_multi_series(infile,&length,exclude,&dim,"",dimset, + verbosity); + else + series=(double**)get_multi_series(infile,&length,exclude,&dim,columns, + dimset,verbosity); + + maxmax=0.0; + for (i=0;i maxmax) + maxmax=max; + } + + if (epsset) + eps /= maxmax; + + check_alloc(list=(long*)malloc(sizeof(long)*length)); + check_alloc(box=(long**)malloc(sizeof(long*)*BOX)); + for (i=0;i +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Resample the data" + +unsigned long length=ULONG_MAX,exclude=0; +unsigned int column=1,order=4; +unsigned int verbosity=0xff; +char *outfile=NULL,stdo=1; +char *infile=NULL; +double *series,sampletime=0.5; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l length of file [default is whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default is 0]\n"); + fprintf(stderr,"\t-c column to read [default is 1]\n"); + fprintf(stderr,"\t-s new sampling time (in units of the old one)" + " [default is %f]\n",sampletime); + fprintf(stderr,"\t-p order of the interpolation [default is %d]\n",order); + fprintf(stderr,"\t-o output file name [default is 'datafile'.rs]\n"); + fprintf(stderr,"\t-V verbosity level [default is 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n\n"); + exit(0); +} + +void scan_options(int argc,char **argv) +{ + char *out; + + if ((out=check_option(argv,argc,'s','f')) != NULL) + sscanf(out,"%lf",&sampletime); + if ((out=check_option(argv,argc,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(argv,argc,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(argv,argc,'c','u')) != NULL) + sscanf(out,"%u",&column); + if ((out=check_option(argv,argc,'p','u')) != NULL) + sscanf(out,"%u",&order); + if ((out=check_option(argv,argc,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(argv,argc,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +int main(int argc,char **argv) +{ + char stdi=0; + long i,j,itime,itime_old; + int horder,horder2; + double **mat,*vec,**imat,*coef; + double time,htime,new_el; + FILE *file=NULL; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,&column,verbosity); + if (infile == NULL) + stdi=1; + + if (outfile == NULL) { + if (!stdi) { + check_alloc(outfile=(char*)calloc(strlen(infile)+4,(size_t)1)); + strcpy(outfile,infile); + strcat(outfile,".rs"); + } + else { + check_alloc(outfile=(char*)calloc((size_t)9,(size_t)1)); + strcpy(outfile,"stdin.rs"); + } + } + if (!stdo) + test_outfile(outfile); + + series=(double*)get_series(infile,&length,exclude,column,verbosity); + + horder=order+1; + horder2=(horder+1)/2-horder; + + check_alloc(mat=(double**)malloc(sizeof(double*)*horder)); + for (i=0;i +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Rescales the data" + +unsigned long length=ULONG_MAX,exclude=0; +unsigned int dim=1; +unsigned int verbosity=0xff; +char *column=NULL; +char *outfile=NULL,stdo=1,set_av=0,set_var=0,dimset=0; +char *infile=NULL; +double **series; +double xmin=0.0,xmax=1.0; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to ignore [default: 0]\n"); + fprintf(stderr,"\t-m # of components to be read [default: %u]\n",dim); + fprintf(stderr,"\t-c columns to read [default: 1,...,# of components]\n"); + fprintf(stderr,"\t-z minimum of the new series [default: 0.0]\n"); + fprintf(stderr,"\t-Z maximum of the new series [default: 1.0]\n"); + fprintf(stderr,"\t-a create a series with average value equals 0\n"); + fprintf(stderr,"\t-v create a series with variance 1\n"); + fprintf(stderr,"\t-o output file name [default: 'datafile'.res']\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'m','u')) != NULL) { + sscanf(out,"%u",&dim); + dimset=1; + } + if ((out=check_option(in,n,'c','s')) != NULL) + column=out; + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'z','f')) != NULL) + sscanf(out,"%lf",&xmin); + if ((out=check_option(in,n,'Z','f')) != NULL) + sscanf(out,"%lf",&xmax); + if ((out=check_option(in,n,'a','n')) != NULL) + set_av=1; + if ((out=check_option(in,n,'v','n')) != NULL) + set_var=1; + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +int main(int argc,char **argv) +{ + char stdi=0; + FILE *file; + double min,max; + double av,varianz; + long i,n; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,NULL,verbosity); + if (infile == NULL) + stdi=1; + + if (outfile == NULL) { + if (!stdi) { + check_alloc(outfile=(char*)calloc(strlen(infile)+5,(size_t)1)); + strcpy(outfile,infile); + strcat(outfile,".res"); + } + else { + check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1)); + strcpy(outfile,"stdin.res"); + } + } + if (!stdo) + test_outfile(outfile); + + if (xmin >= xmax) { + fprintf(stderr,"Choosing the minimum larger or equal the maximum\n" + "makes no sense. Exiting!\n"); + exit(RESCALE__WRONG_INTERVAL); + } + + if (column == NULL) + series=(double**)get_multi_series(infile,&length,exclude,&dim,"",dimset, + verbosity); + else + series=(double**)get_multi_series(infile,&length,exclude,&dim,column, + dimset,verbosity); + + for (n=0;no=F1MNI(ciOnN{hIs=HC=6hI0+`NX;bDdPU$|0sz8Bp2@vC)WwgDiGpyOv?77c@SgndSX&T!K8$?G`j(r~B$bGm9sZ?km~ z4eru)Lpq{KoUR*rNk3Jy5rvZksEBuy*xTuEtgk=o`aP&1@9S^eR=Y_y-U1fl1!OcC zCiJrxQ7`dHty#aQ5oQD=2}#oTN!Lp}fa{Vw`q_^^t+UEb==XZGL;WC$KLwu>Y{&Y@ zk7;+}$D|NOh@2*V1bDj~WfA5v31WH|K+P}=?#R#&?vj4>`n+*@>R!}-wfrxPfNJ?z zL((82T{^1T);Jvcan&wcly}Skd659HDF0BlMxLn3fPz?V!U+H24JWrlpOi{qDb$aT*Hz8v z(e+?x@6NYMrJig~^Tdl_Aj^wJ9{kNryHo<*?D}5-<>!!gN!$+~+;E(LhQ$RwlW`Q@ z1>VRnuKzD+cM1{9B>xi05TWA0g@k+KBzJY!i3!V_{k%my&;gmhanGiID{6Y(vQZG4@$GKzDCFf z@jy+J7nFY=a9)VSGN} z%7PX*3)Pi@s@AmX)E`?_Zs(K{M|#Mw$P9!_G7Y;z9D zede8TS%`gM<+xUe4*nOK6w2`Nt8`@@FHo+Gd-J=F#eG@{K7Zy8P5EkYfrQW=DHPyK zwbS=I_o90Np)J;ZbG&J7PBx20^0Z3OITr~cAtc7(df3(4cs|*%UTBTtSlM^-n%J_( zG>vUo@VG7mp_5^kcnQcBqXn?=Fz}yBTCp&C?aGm;_`1&jUr4|(OThH>hd6((@(lYz zoL`p2DHh}9kdBt+GxZ*UI?%8!gL!8hw9|=NJIrp z{gy!TZZV^Arph%eH???KPE$iE2+>i?@(d3*@&BBmFd`~zYk@!&#zIs@@-rzHh0@EA zO7QEeHg-Refl%xwq5E$?3Jci6ja-CF5S3y#78OxzfS=LTKxkQ@FgksW0TSKXlCxq_ zY|!xwJh1vmZ!FFMki81Lu=WK&3a&701Hd+TEn><6AQbagcs>qp$aa;auqcZ7Y)d6_ zJE6m_3&D6qzZ6su2;Z$#5Es*bi|C9|7Fa-=MPYU8T7%dcbdNO$AW9esvhicp-q|e( z%tb!kZTVH|cA7&tmdPU8t?~%+WBEqV0F|+dCA81v5aJO&#$*syFX9d^ zx=YDaFYRb0a=$J>za-SDg4;wx>l9yC%&gV3!eJ?s*FaUwIGaTbgZ@cDd|BWPxONI{;lh-zO6-34 zvR_CmhSC!-rIBa7t)DxjgsXMhmMm&pv|@qom^xDun5|O$;Ei*%N3<&i%GaP$vBU%I zExS0SNL))aYjV&dr z`5JaEXUW$cg_1EGYKmq+699_fwajZRX$^7!Hu4SVT6U1`O)+g1Hd0`75^T24^7;za zR|E;P!di0hqiSo5uuEKcv~p8Qfo|K|PzM0U8p{JkwvEmNlesj)#Kd+ByFftelMQQX zKAO4|u-1nxYpUdXC5fK7 zr8JWDwYAw}6iaNKni?jxdf{Md0JeTr=`L4*beqlFo~t$^n9$6c$!|LH7PDLd<#64i zEsXZN2;lu5i;9WIZu&TQ804j2Te~AR4=WjjmUHiJ1Hs^JHjG( z?uL(A+}gL8jkrnCE~<48U^?SRiNF%DW~-N|){Px6nzQ~co{^lu%O$3=!47aTBg)(s z@*?C6O#C=;MJL(0sQAhAdKs28{WBuiJ3n#RPSxd2f@L!ID$g!ihSS>E5a)#!_@1>j zKKHb&kt@H$NPO<*Fk)bHw2VL2iL9mL=iHQ?<{;0P|6CPkFDiP?s%A4YxR&ueOg4v9$;9oRj9qlt&Z|UEtN=DFP#gxvHAdrs@ALPt z2qZs&)*5>>>?!w;+!ny#Fu0jYHXfy6SvB+=KtCF^aN^JVdLwID*=EqU~o?~3)7<2${v z5xswhKb{r)^9wk?$tNq+zsU!qYhkyTBtOZ|L~``M8Q~Zj^cx@IZ4M}6ljZHLzUk80@BqhDNDA%gyMD&%599Nu4^l|kW+~~3MQ+#S~ zrOwdFfBuu*A6~bbuuVy)8L3Rsnd<~QiU4d18OyaQ3UJu9+_~rNN@3IrYf3ScQD?3; zTgK7#;Kou53DUhLwjx<18yT=^&Pd*94rvCxcmd>#i&%IiAd~nMXA*qVKOV8Yuv&tQ z{UX~Q_QEm0UBI_|4|4puoAl|;M+30EROw-HftD7uQLo| zzo2TqW;0c(8&E8yG_B4^drbox*``^$pxkt6b}yvRvCw2H!t@`Pu^F}O~ zUsK!^n0`-YLaY1^5k8*#Y;JEBF>svEOL3ye0-Jjy;m0=yff-;gE15Me6m`J)W5n`J z(x_jyol~coD-330^F<+!dApO*=XlWHZ$%l$K+M z?WudQz&4p?PhW>9&i5|ZFXdmfx-vttHl>Q+M!t8i!goCUD?sOMz0>-QjFntfbg7HK z%dxoqzM&bcw`)}2(Obeu2RFs(&Fya^Xep8w5tSl~ZrS_+!{3Iqj1lzN25Jd2u6-# z--dF`SSG4{!i6_-LN}gac5>N%ai+ zF*ShqaFkt&z0x)Wd%)c0f2{pRE5@MT$W9ZKF?D^^v=*g`+l1FqT~izNf+aJQX{$!&m-?C9(ZP zr;deHil90vO8lv<#*CeY7;b8(!I{r5A3|qK!ig64Rs8#7limk0sU-DU=t<4qs4Cq{W&w$Mlbp{e>6C{44yu}D1K!Y`B++zNmKnQDM ztIn8}rzvY$MOph6J(<>$wP__0)hP{NbCddkjoaJD-!Mbz;{+zo&aWw>FqLl_EgLq4 z)Id3n4*r4vG|Ch$^7)%SSNf{c83pd(&{Kvy!=ft!d|8gZ6KAHbGDC%Ql0|dP*w|1J zr);0hLkR~uS zoz_Y1+;QL3+BNrIPP4(%(M|BU#I_X_cgeN$^Tr9=JUN$*>(ev$!ntTPKM=c;0n9mS zAokvDAdvwl_Wo=bmcS+U!EA{3`v$QO^V{_@LhK_2(so*Hw{hLZcT))PzFBWOZtdj6 zX|;&`lY(nC&fhrz(yCvcUZ3N0h+4Z@|CQJ;709X6c3V!f?z9lmdHvF9fzqa$FRstq zbqVyoiNC?u{&3~EjkoRzso1k&HA2nkceQ4{c6s6eQBBwRClej1XdXND(~5qt0c166 z$OynOhsSJBOezNpH3}cBX|*!c>HI_O%57aaDK)u-$(;S8(QJ`}atvU4^PN}=7aNVyXjoi@HJTN^3-up8W&fMOXm{sXlA^vowq>1POXUoH)eL#0M!G0 znkR2tAZIon$Qkfm0OPL!LhIe>*)Oe@tEXg8r5j`ZNfNLu8VF0bhYW6;xLC= z0La1KNg#(J~vS*El2Pw!)7-kma z;gok1fXcNUYTmbM@7&YIxeI)M<22tO8kG4Pa`@9UjOIDO*583iy@T;I&o64ffM$Vj zcEMlOPFq0cKdj$j;7i^b6v(*g^?WDY1;rsT-1I=%Qb;C|W*R^x^t$RU^_7{MR$kD;PQGl4k-1f`s3v4{fG=k{C@wi=V`zh1b zx`0K6JFlac`Ta&P=by^VC7lk#TXv&h((9RC=bdxXZZtC%aqe86w$F%NhQ8vJ=${?* ztjema%Brl&s;tVYtjema%Brl&s;tVYtjema%Brl&s;tVYtjema%Brl&s{GB${{j2$ JbSeON001#yEA#*W literal 0 HcmV?d00001 diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/check_alloc.c b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/check_alloc.c new file mode 100644 index 0000000..8d58878 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/check_alloc.c @@ -0,0 +1,31 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/* Author: Rainer Hegger Last modified: Jul 15, 1999 */ +#include +#include +#include "tisean_cec.h" + +void check_alloc(void *pnt) +{ + if (pnt == NULL) { + fprintf(stderr,"check_alloc: Couldn't allocate enough memory. Exiting\n"); + exit(CHECK_ALLOC_NOT_ENOUGH_MEMORY); + } +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/check_option.c b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/check_option.c new file mode 100644 index 0000000..c1c359e --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/check_option.c @@ -0,0 +1,252 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger Last modified: Aug 19, 1999 */ +#include +#include +#include +#include +#include "tisean_cec.h" + +extern void check_alloc(void*); +/* possible types are + 'd' (long) integer + 'u' unsigned (long) + '1' one or two unsigned (long) numbers, separated by comma, if two + '2' two unsigned (long) numbers separated by a comma + '3' three unsigned (long) numbers separated by commas + 'f' float + 's' string + 'o' optional string (must only begin with a minus if there is no space) + 'n' no parameter + */ + +void check_unsigned(char *tocheck,int which) +{ + int i,n; + char ok=1; + + n=strlen(tocheck); + for (i=0;i= (len-1)) { + fprintf(stderr,"Wrong type of parameter for flag -%c. Has to be" + " unsigned,unsigned\n",which); + exit(CHECK_OPTION_NOT_TWO); + } + for (j=0;j= (len-1)) { + fprintf(stderr,"Wrong type of parameter for flag -%c. Has to be" + " unsigned,unsigned,unsigned\n",which); + exit(CHECK_OPTION_NOT_THREE); + } + + for (j=i+1;j= (len-1)) { + fprintf(stderr,"Wrong type of parameter for flag -%c. Has to be" + " unsigned,unsigned,unsigned\n",which); + exit(CHECK_OPTION_NOT_THREE); + } + + for (k=0;k 2) { + switch(type) { + case 'u': check_unsigned(in[i]+2,which);break; + case 'd': check_integer(in[i]+2,which);break; + case 'f': check_float(in[i]+2,which);break; + case '2': check_two(in[i]+2,which);break; + case '3': check_three(in[i]+2,which);break; + } + if (ret != NULL) + free(ret); + check_alloc(ret=(char*)calloc(strlen(in[i]+2)+1,(size_t)1)); + strcpy(ret,in[i]+2); + in[i]=NULL; + } + else { + in[i]=NULL; + i++; + if (i < n) { + if (in[i] != NULL) { + switch(type) { + case 'u': check_unsigned(in[i],which);break; + case 'd': check_integer(in[i],which);break; + case 'f': check_float(in[i],which);break; + case '2': check_two(in[i],which);break; + case '3': check_three(in[i]+2,which);break; + case 'o': ok=check_optional(in[i],which);break; + } + if (ok) { + if (ret != NULL) + free(ret); + check_alloc(ret=(char*)calloc(strlen(in[i])+1,(size_t)1)); + strcpy(ret,in[i]); + in[i]=NULL; + } + else { + i--; + if (ret != NULL) + free(ret); + ret=NULL; + } + } + } + else { + if (ret != NULL) { + free(ret); + ret=NULL; + } + } + } + } + else { + in[i]=NULL; + } + } + } + } + + if (((type == 'o') || (type == 'n')) && (ret == NULL) && wasfound) + return ""; + + if (wasfound && (ret == NULL)) { + fprintf(stderr,"The option -%c needs some value. Exiting!\n",which); + exit(CHECK_OPTION_C_NO_VALUE); + } + return ret; +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/diffc.log b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/diffc.log new file mode 100644 index 0000000..a69e129 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/diffc.log @@ -0,0 +1,11 @@ +--- get_multi_series.c 2004-07-23 10:01:25.000000000 +0200 ++++ /home/hegger/TISEAN_2.1/source_c/routines/get_multi_series.c 2000-05-26 08:24:44.000000000 +0200 +@@ -135,7 +135,7 @@ + fprintf(stderr,"Line %lu ignored: %s",allcount,input); + break; + } +- if ((count == 0) && (i == *col) && (verbosity&VER_FIRST_LINE)) { ++ if ((verbosity&VER_FIRST_LINE) && (count == 0)) { + fprintf(stderr,"get_multi_series: first data item(s) used:\n"); + for (i=0;i< *col;i++) + fprintf(stderr,"%lf ",x[i][0]); diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/diffh.log b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/diffh.log new file mode 100644 index 0000000..e69de29 diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/eigen.c b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/eigen.c new file mode 100644 index 0000000..11dc751 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/eigen.c @@ -0,0 +1,522 @@ +#include +#include +#include +#include "tisean_cec.h" + +typedef double doublereal; +typedef int integer; + +#define abs(x) (((x)>=0.0)?(x):-(x)) +#define min(x,y) (((x)<=(y))?(x):(y)) +#define max(x,y) (((x)>=(y))?(x):(y)) + +static doublereal c_b10 = 1.; + +extern void check_alloc(void*); + +double d_sign(double *a,double *b) +{ + double x; + x = (*a >= 0 ? *a : - *a); + return ( *b >= 0 ? x : -x); +} + +doublereal pythag(doublereal *a, doublereal *b) +{ + doublereal ret_val, d__1, d__2, d__3; + static doublereal p, r__, s, t, u; + + d__1 = abs(*a), d__2 = abs(*b); + p = max(d__1,d__2); + if (p == 0.) { + goto L20; + } + d__2 = abs(*a), d__3 = abs(*b); + d__1 = min(d__2,d__3) / p; + r__ = d__1 * d__1; +L10: + t = r__ + 4.; + if (t == 4.) { + goto L20; + } + s = r__ / t; + u = s * 2. + 1.; + p = u * p; + d__1 = s / u; + r__ = d__1 * d__1 * r__; + goto L10; +L20: + ret_val = p; + return ret_val; +} + + +int tred2(integer *nm, integer *n, doublereal *a, + doublereal *d__, doublereal *e, doublereal *z__) +{ + integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3; + doublereal d__1; + + double sqrt(doublereal), d_sign(doublereal *, doublereal *); + + static doublereal f, g, h__; + static integer i__, j, k, l; + static doublereal hh; + static integer ii, jp1; + static doublereal scale; + + + +/* this subroutine is a translation of the algol procedure tred2, */ +/* num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson. */ +/* handbook for auto. comp., vol.ii-linear algebra, 212-226(1971). */ + +/* this subroutine reduces a real symmetric matrix to a */ +/* symmetric tridiagonal matrix using and accumulating */ +/* orthogonal similarity transformations. */ + +/* on input */ + +/* nm must be set to the row dimension of two-dimensional */ +/* array parameters as declared in the calling program */ +/* dimension statement. */ + +/* n is the order of the matrix. */ + +/* a contains the real symmetric input matrix. only the */ +/* lower triangle of the matrix need be supplied. */ + +/* on output */ + +/* d contains the diagonal elements of the tridiagonal matrix. */ + +/* e contains the subdiagonal elements of the tridiagonal */ +/* matrix in its last n-1 positions. e(1) is set to zero. */ + +/* z contains the orthogonal transformation matrix */ +/* produced in the reduction. */ + +/* a and z may coincide. if distinct, a is unaltered. */ + +/* questions and comments should be directed to burton s. garbow, */ +/* mathematics and computer science div, argonne national laboratory */ + +/* this version dated august 1983. */ + +/* ------------------------------------------------------------------ */ + + z_dim1 = *nm; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --e; + --d__; + a_dim1 = *nm; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + + i__2 = *n; + for (j = i__; j <= i__2; ++j) { + z__[j + i__ * z_dim1] = a[j + i__ * a_dim1]; + } + + d__[i__] = a[*n + i__ * a_dim1]; + } + + if (*n == 1) { + goto L510; + } + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = *n + 2 - ii; + l = i__ - 1; + h__ = 0.; + scale = 0.; + if (l < 2) { + goto L130; + } + i__2 = l; + for (k = 1; k <= i__2; ++k) { + scale += (d__1 = d__[k], abs(d__1)); + } + + if (scale != 0.) { + goto L140; + } +L130: + e[i__] = d__[l]; + + i__2 = l; + for (j = 1; j <= i__2; ++j) { + d__[j] = z__[l + j * z_dim1]; + z__[i__ + j * z_dim1] = 0.; + z__[j + i__ * z_dim1] = 0.; + } + + goto L290; + +L140: + i__2 = l; + for (k = 1; k <= i__2; ++k) { + d__[k] /= scale; + h__ += d__[k] * d__[k]; + } + + f = d__[l]; + d__1 = sqrt(h__); + g = -d_sign(&d__1, &f); + e[i__] = scale * g; + h__ -= f * g; + d__[l] = f - g; + i__2 = l; + for (j = 1; j <= i__2; ++j) { + e[j] = 0.; + } + + i__2 = l; + for (j = 1; j <= i__2; ++j) { + f = d__[j]; + z__[j + i__ * z_dim1] = f; + g = e[j] + z__[j + j * z_dim1] * f; + jp1 = j + 1; + if (l < jp1) { + goto L220; + } + + i__3 = l; + for (k = jp1; k <= i__3; ++k) { + g += z__[k + j * z_dim1] * d__[k]; + e[k] += z__[k + j * z_dim1] * f; + } + +L220: + e[j] = g; + } + f = 0.; + + i__2 = l; + for (j = 1; j <= i__2; ++j) { + e[j] /= h__; + f += e[j] * d__[j]; + } + + hh = f / (h__ + h__); + i__2 = l; + for (j = 1; j <= i__2; ++j) { + e[j] -= hh * d__[j]; + } + i__2 = l; + for (j = 1; j <= i__2; ++j) { + f = d__[j]; + g = e[j]; + + i__3 = l; + for (k = j; k <= i__3; ++k) { + z__[k + j * z_dim1] = z__[k + j * z_dim1] - f * e[k] - g * + d__[k]; + } + + d__[j] = z__[l + j * z_dim1]; + z__[i__ + j * z_dim1] = 0.; + } + +L290: + d__[i__] = h__; + } + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + l = i__ - 1; + z__[*n + l * z_dim1] = z__[l + l * z_dim1]; + z__[l + l * z_dim1] = 1.; + h__ = d__[i__]; + if (h__ == 0.) { + goto L380; + } + + i__2 = l; + for (k = 1; k <= i__2; ++k) { + d__[k] = z__[k + i__ * z_dim1] / h__; + } + + i__2 = l; + for (j = 1; j <= i__2; ++j) { + g = 0.; + + i__3 = l; + for (k = 1; k <= i__3; ++k) { + g += z__[k + i__ * z_dim1] * z__[k + j * z_dim1]; + } + + i__3 = l; + for (k = 1; k <= i__3; ++k) { + z__[k + j * z_dim1] -= g * d__[k]; + } + } + +L380: + i__3 = l; + for (k = 1; k <= i__3; ++k) { + z__[k + i__ * z_dim1] = 0.; + } + + } + +L510: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = z__[*n + i__ * z_dim1]; + z__[*n + i__ * z_dim1] = 0.; + } + + z__[*n + *n * z_dim1] = 1.; + e[1] = 0.; + return 0; +} + +int tql2(integer *nm, integer *n, doublereal *d__, + doublereal *e, doublereal *z__, integer *ierr) +{ + integer z_dim1, z_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + + double d_sign(doublereal *, doublereal *); + + static doublereal c__, f, g, h__; + static integer i__, j, k, l, m; + static doublereal p, r__, s, c2, c3; + static integer l1, l2; + static doublereal s2; + static integer ii; + static doublereal dl1, el1; + static integer mml; + static doublereal tst1, tst2; + extern doublereal pythag_(doublereal *, doublereal *); + + + +/* this subroutine is a translation of the algol procedure tql2, */ +/* num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and */ +/* wilkinson. */ +/* handbook for auto. comp., vol.ii-linear algebra, 227-240(1971). */ + +/* this subroutine finds the eigenvalues and eigenvectors */ +/* of a symmetric tridiagonal matrix by the ql method. */ +/* the eigenvectors of a full symmetric matrix can also */ +/* be found if tred2 has been used to reduce this */ +/* full matrix to tridiagonal form. */ + +/* on input */ + +/* nm must be set to the row dimension of two-dimensional */ +/* array parameters as declared in the calling program */ +/* dimension statement. */ + +/* n is the order of the matrix. */ + +/* d contains the diagonal elements of the input matrix. */ + +/* e contains the subdiagonal elements of the input matrix */ +/* in its last n-1 positions. e(1) is arbitrary. */ + +/* z contains the transformation matrix produced in the */ +/* reduction by tred2, if performed. if the eigenvectors */ +/* of the tridiagonal matrix are desired, z must contain */ +/* the identity matrix. */ + +/* on output */ + +/* d contains the eigenvalues in ascending order. if an */ +/* error exit is made, the eigenvalues are correct but */ +/* unordered for indices 1,2,...,ierr-1. */ + +/* e has been destroyed. */ + +/* z contains orthonormal eigenvectors of the symmetric */ +/* tridiagonal (or full) matrix. if an error exit is made, */ +/* z contains the eigenvectors associated with the stored */ +/* eigenvalues. */ + +/* ierr is set to */ +/* zero for normal return, */ +/* j if the j-th eigenvalue has not been */ +/* determined after 30 iterations. */ + +/* calls pythag for dsqrt(a*a + b*b) . */ + +/* questions and comments should be directed to burton s. garbow, */ +/* mathematics and computer science div, argonne national laboratory */ + +/* this version dated august 1983. */ + +/* ------------------------------------------------------------------ */ + + z_dim1 = *nm; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --e; + --d__; + + *ierr = 0; + if (*n == 1) { + goto L1001; + } + + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + e[i__ - 1] = e[i__]; + } + + f = 0.; + tst1 = 0.; + e[*n] = 0.; + + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + j = 0; + h__ = (d__1 = d__[l], abs(d__1)) + (d__2 = e[l], abs(d__2)); + if (tst1 < h__) { + tst1 = h__; + } + i__2 = *n; + for (m = l; m <= i__2; ++m) { + tst2 = tst1 + (d__1 = e[m], abs(d__1)); + if (tst2 == tst1) { + goto L120; + } + } + +L120: + if (m == l) { + goto L220; + } +L130: + if (j == 30) { + goto L1000; + } + ++j; + l1 = l + 1; + l2 = l1 + 1; + g = d__[l]; + p = (d__[l1] - g) / (e[l] * 2.); + r__ = pythag(&p, &c_b10); + d__[l] = e[l] / (p + d_sign(&r__, &p)); + d__[l1] = e[l] * (p + d_sign(&r__, &p)); + dl1 = d__[l1]; + h__ = g - d__[l]; + if (l2 > *n) { + goto L145; + } + + i__2 = *n; + for (i__ = l2; i__ <= i__2; ++i__) { + d__[i__] -= h__; + } + +L145: + f += h__; + p = d__[m]; + c__ = 1.; + c2 = c__; + el1 = e[l1]; + s = 0.; + mml = m - l; + i__2 = mml; + for (ii = 1; ii <= i__2; ++ii) { + c3 = c2; + c2 = c__; + s2 = s; + i__ = m - ii; + g = c__ * e[i__]; + h__ = c__ * p; + r__ = pythag(&p, &e[i__]); + e[i__ + 1] = s * r__; + s = e[i__] / r__; + c__ = p / r__; + p = c__ * d__[i__] - s * g; + d__[i__ + 1] = h__ + s * (c__ * g + s * d__[i__]); + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + h__ = z__[k + (i__ + 1) * z_dim1]; + z__[k + (i__ + 1) * z_dim1] = s * z__[k + i__ * z_dim1] + c__ + * h__; + z__[k + i__ * z_dim1] = c__ * z__[k + i__ * z_dim1] - s * h__; + } + + } + + p = -s * s2 * c3 * el1 * e[l] / dl1; + e[l] = s * p; + d__[l] = c__ * p; + tst2 = tst1 + (d__1 = e[l], abs(d__1)); + if (tst2 > tst1) { + goto L130; + } +L220: + d__[l] += f; + } + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] >= p) { + goto L260; + } + k = j; + p = d__[j]; +L260: + ; + } + + if (k == i__) { + goto L300; + } + d__[k] = d__[i__]; + d__[i__] = p; + + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + p = z__[j + i__ * z_dim1]; + z__[j + i__ * z_dim1] = z__[j + k * z_dim1]; + z__[j + k * z_dim1] = p; + } + +L300: + ; + } + + goto L1001; +L1000: + *ierr = l; +L1001: + return 0; +} + +void eigen(double **mat,unsigned long n,double *eig) +{ + double *trans,*off; + int ierr,i,j,nm=(int)n; + + check_alloc(trans=(double*)malloc(sizeof(double)*nm*nm)); + check_alloc(off=(double*)malloc(sizeof(double)*nm)); + + tred2(&nm,&nm,&mat[0][0],eig,off,trans); + tql2(&nm,&nm,eig,off,trans,&ierr); + + if (ierr != 0) { + fprintf(stderr,"Non converging eigenvalues! Exiting\n"); + exit(EIG2_TOO_MANY_ITERATIONS); + } + + for (i=0;i +#include +#ifndef _MATH_H +#include +#endif + +unsigned long exclude_interval(unsigned long n,long ex0,long ex1, + unsigned long *hf,unsigned long *found) +{ + long i,help; + long lf=0; + + for (i=0;i ex1)) + found[lf++]=help; + } + return lf; +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/find_multi_neighbors.c b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/find_multi_neighbors.c new file mode 100644 index 0000000..14f729e --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/find_multi_neighbors.c @@ -0,0 +1,59 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger Last modified: Jul 9, 1999 */ +#include + +unsigned long find_multi_neighbors(double **s,long **box,long *list,double **x, + unsigned long l,unsigned int bs,unsigned int dim, + unsigned int emb,unsigned int del,double eps, + unsigned long *flist) +{ + unsigned long nf=0; + int i,i1,i2,j,j1,k,k1,li; + int ib=bs-1; + long element; + double dx=0.0; + + i=(int)(x[0][0]/eps)&ib; + j=(int)(x[dim-1][0]/eps)&ib; + + for (i1=i-1;i1<=i+1;i1++) { + i2=i1&ib; + for (j1=j-1;j1<=j+1;j1++) { + element=box[i2][j1&ib]; + while (element != -1) { + for (k=0;k eps) + break; + } + if (dx > eps) + break; + } + if (dx <= eps) + flist[nf++]=element; + element=list[element]; + } + } + } + return nf; +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/find_neighbors.c b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/find_neighbors.c new file mode 100644 index 0000000..e412923 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/find_neighbors.c @@ -0,0 +1,55 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger Last modified: March 1st, 1998 */ +#include + +unsigned long find_neighbors(double *s,long **box,long *list,double *x, + unsigned long l,unsigned int bs,unsigned int dim, + unsigned int del,double eps,unsigned long *flist) +{ + unsigned long nf=0; + int i,i1,i2,j,j1,k,k1; + int ib=bs-1; + long element; + double dx; + + k=(int)((dim-1)*del); + i=(int)(x[-k]/eps)&ib; + j=(int)(x[0]/eps)&ib; + + for (i1=i-1;i1<=i+1;i1++) { + i2=i1&ib; + for (j1=j-1;j1<=j+1;j1++) { + element=box[i2][j1&ib]; + while (element != -1) { + for (k=0;k eps) + break; + } + if (k == dim) + flist[nf++]=element; + element=list[element]; + } + } + } + return nf; +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/get_multi_series.c b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/get_multi_series.c new file mode 100644 index 0000000..96a0c24 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/get_multi_series.c @@ -0,0 +1,190 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger Last modified: Sep 3, 1999 */ +/*Note: Keep in mind that the first index runs the dimension, + the second the time series index */ +#include +#include +#include +#include +#include "tsa.h" +#include "tisean_cec.h" + +#define SIZE_STEP 1000 +extern void check_alloc(void*); + +double **get_multi_series(char *name,unsigned long *l,unsigned long ex, + unsigned int *col,char *which,char colfix, + unsigned int verbosity) +{ + char *input,**format; + int i,j; + unsigned int *hcol,maxcol=0,colcount=0; + unsigned long count,max_size=SIZE_STEP,hl,allcount; + int input_size=INPUT_SIZE; + double **x; + FILE *fin; + + if (strlen(which) > 0) { + colcount=1; + for (i=0;i maxcol) + maxcol=hcol[i]; + while ((int)(*which) && !isspace((unsigned int)(*which))) + which++; + while ((int)(*which) && isspace((unsigned int)(*which))) + which++; + if (!((int)(*which))) + break; + } + else + i= -1; + + if (*which) + sscanf(which,"%u",&hcol[i]); + else + for (j=i+1;j< *col;j++) + hcol[j]= ++maxcol; + + if (verbosity&VER_INPUT) { + fprintf(stderr,"Using columns: "); + for (i=0;i< *col;i++) + fprintf(stderr,"%d ",hcol[i]); + fprintf(stderr,"\n"); + } + + check_alloc(format=(char**)malloc(sizeof(char*)* *col)); + for (i=0;i< *col;i++) { + check_alloc(format[i]=(char*)calloc((size_t)(4*hcol[i]),(size_t)1)); + strcpy(format[i],""); + for (j=1;j count) + for (i=0;i< *col;i++) + check_alloc(x[i]=(double*)realloc(x[i],sizeof(double)*count)); + + return x; +} +#undef SIZE_STEP diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/get_series.c b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/get_series.c new file mode 100644 index 0000000..53a3cb6 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/get_series.c @@ -0,0 +1,110 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger Last modified: Sep 3, 1999 */ +#include +#include +#include +#include "tsa.h" +#include "tisean_cec.h" + +#define SIZE_STEP 1000 +extern void check_alloc(void*); + +double *get_series(char *name,unsigned long *l,unsigned long ex, + unsigned int col,unsigned int verbosity) +{ + char *input,*format; + int i; + unsigned long count,allcount,max_size=SIZE_STEP,hl; + int input_size=INPUT_SIZE; + double *x; + FILE *fin; + + check_alloc(input=(char*)calloc((size_t)input_size,(size_t)1)); + check_alloc(format=(char*)calloc((size_t)(4*col),(size_t)1)); + strcpy(format,""); + for (i=1;i count) + check_alloc(x=(double*)realloc(x,sizeof(double)*count)); + + return x; +} +#undef SIZE_STEP diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/invert_matrix.c b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/invert_matrix.c new file mode 100644 index 0000000..e198fb6 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/invert_matrix.c @@ -0,0 +1,65 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/* Author: Rainer Hegger Last modified: Sep 5, 2004*/ +/* Changes: + * Sep 5, 2004: added the extern check_alloc line + */ +#include +#include +#include + +extern void check_alloc(void*); + +double **invert_matrix(double **mat,unsigned int size) +{ + int i,j,k; + double **hmat,**imat,*vec; + extern void solvele(double**,double*,unsigned int); + + check_alloc(hmat=(double**)malloc(sizeof(double*)*size)); + for (i=0;i + +extern void check_alloc(void *); + +unsigned int **make_multi_index(unsigned int comps,unsigned int emb, + unsigned int del) +{ + unsigned long i,alldim; + unsigned int **mmi; + + alldim=comps*emb; + check_alloc(mmi=(unsigned int**)malloc(sizeof(unsigned int*)*2)); + for (i=0;i<2;i++) + check_alloc(mmi[i]=(unsigned int*)malloc(sizeof(unsigned int)*alldim)); + + for (i=0;i +#include +#include +#include "tsa.h" + +char* myfgets(char *str,int *size,FILE *fin,unsigned int verbosity) +{ + char *ret; + char *hstr=NULL; + char last; + + ret=fgets(str,*size,fin); + if (ret == NULL) + return NULL; + + last=str[strlen(str)-1]; + + while (last != '\n') { + *size += INPUT_SIZE; + check_alloc(hstr=(char*)calloc((size_t)INPUT_SIZE,(size_t)1)); + check_alloc(str=realloc(str,(size_t)*size)); + ret=fgets(hstr,INPUT_SIZE,fin); + strcat(str,hstr); + if (verbosity&VER_INPUT) + fprintf(stderr,"Line in file too long. Increasing input size\n"); + last=str[strlen(str)-1]; + free(hstr); + } + + if (ret == NULL) + return NULL; + else + return str; +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/rand.c b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/rand.c new file mode 100644 index 0000000..4f8b56b --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/rand.c @@ -0,0 +1,157 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger. Last modified: Feb 12, 2006 */ +/* Changes: + Sep 5, 2004 : add extern definition of check_alloc + Feb 12, 2006: add was_set to avoid multiple initialisations +*/ + +#define __RANDOM + +#ifndef _STDLIB_H +#include +#endif + +#ifndef _LIMITS_H +#include +#endif + +#ifndef _MATH_H +#include +#endif + + +#ifndef M_PI +#define M_PI 3.1415926535897932385E0 +#endif + +extern void check_alloc(void*); + +static unsigned long *rnd_array,rnd69,*rnd1279,factor; +static unsigned long *nexti,rndtime,rndtime1,rndtime2,rndtime3,*next1279; +static unsigned long t1279,t1279_1,t1279_2,t1279_3; +static double lo_limit; +static char rnd_init_was_set=0; + +void rnd_init(unsigned long iseed) +{ + int i; + unsigned long z,index; + + if (rnd_init_was_set == 1) + return ; + + rnd_init_was_set=1; + + if (sizeof(long) == 8) { + factor=13*13*13*13; + factor=factor*factor*factor*13; + } + else + factor=69069; + lo_limit=(double)ULONG_MAX; + + check_alloc(rnd_array=(unsigned long *)malloc(9689*sizeof(unsigned long))); + check_alloc(nexti=(unsigned long *)malloc(9689*sizeof(long))); + check_alloc(rnd1279=(unsigned long *)malloc(1279*sizeof(unsigned long))); + check_alloc(next1279=(unsigned long *)malloc(1279*sizeof(long))); + + rnd_array[0]=rnd1279[0]=iseed; + rnd69=iseed; + index=iseed; + nexti[0]=next1279[0]=1; + + for (i=1;i<9689;i++) { + rnd_array[i]=factor*rnd_array[i-1]+1; + nexti[i]=i+1; + } + + for (i=1;i<1279;i++) { + rnd1279[i]=factor*rnd1279[i-1]+1; + next1279[i]=i+1; + } + nexti[9688]=next1279[1278]=0; + + for (i=1;i<2000;i++) { + index=factor*index+1; + z=rnd1279[((index>>10)%1279)]; + z=(z<<10)+(z>>10); + index=factor*index+1; + rnd1279[((index>>10)%1279)] += z; + } + + nexti[9688]=next1279[1278]=0; + rndtime=9688; + rndtime1=9688-157; + rndtime2=9688-314; + rndtime3=9688-471; + t1279=1278; + t1279_1=1278-216; + t1279_2=1278-299; + t1279_3=1278-598; +} + +unsigned long rnd_long(void) +{ + rndtime=nexti[rndtime]; + rndtime1=nexti[rndtime1]; + rndtime2=nexti[rndtime2]; + rndtime3=nexti[rndtime3]; + rnd_array[rndtime] ^= rnd_array[rndtime1] + ^rnd_array[rndtime2]^rnd_array[rndtime3]; + + return rnd_array[rndtime]; +} + +unsigned long rnd_1279(void) +{ + t1279=next1279[t1279]; + t1279_1=next1279[t1279_1]; + t1279_2=next1279[t1279_2]; + t1279_3=next1279[t1279_3]; + + rnd1279[t1279] += (rnd1279[t1279_1] + rnd1279[t1279_2] + + rnd1279[t1279_3]); + return rnd1279[t1279]; +} + +unsigned long rnd69069(void) +{ + return (rnd69=rnd69*factor+1); +} + +double gaussian(double sigma) +{ + static unsigned long gausscount=0; + double x,r,u,phi; + static double y; + + if (!(gausscount++ & 0x1)) { + phi=2.0*M_PI*(double)rnd_1279()/lo_limit; + u=(double)rnd_1279()/lo_limit; + r=sqrt(-2.0*sigma*sigma*log(u)); + x=r*cos(phi); + y=r*sin(phi); + + return x; + } + else + return y; +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/rand_arb_dist.c b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/rand_arb_dist.c new file mode 100644 index 0000000..e539e60 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/rand_arb_dist.c @@ -0,0 +1,94 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger Last modified: Feb 11, 2006 */ +/*Changes: + Feb 11, 2006: First version +*/ +/*Comment: + Creates a sequence of random numbers with arbitrary distribution + Input Paramters: x=original data defining the distribution + nx= length of x + nc= number of random numbers to create + nb= number of bins for the distribution + iseed = seed for the random number generator + Return: rand = array containing the nc random numbers +*/ + +#ifndef _STDLIB_H +#include +#endif + +#ifndef _LIMITS_H +#include +#endif + +#ifndef _TIME_H +#include +#endif + +extern void rescale_data(double*,unsigned long,double*,double*); +extern void check_alloc(void*); +extern unsigned long rnd_long(void); +extern void rnd_init(unsigned long); + +double *rand_arb_dist(double *x,unsigned long nx,unsigned long nc, + unsigned int nb,unsigned long iseed) +{ + double h,min,inter,*randarb,drnd,epsinv=1.0/(double)nb; + unsigned long i,j,*box,hrnd,nall=nx+nb; + + rescale_data(x,nx,&min,&inter); + + check_alloc(box=(unsigned long*)malloc(sizeof(unsigned long)*nb)); + for (i=0;i= 1.0) + h -= epsinv/2.0; + j=(unsigned int)(h*nb); + box[j]++; + } + for (i=1;i= hrnd) + break; + drnd=(double)rnd_long()/(double)ULONG_MAX*epsinv; + randarb[i]=min+((double)j*epsinv+drnd)*inter; + } + + free(box); + + return randarb; +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/rescale_data.c b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/rescale_data.c new file mode 100644 index 0000000..16fd948 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/rescale_data.c @@ -0,0 +1,50 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger Last modified: Sep 5, 2004*/ +/* Changes: + * Sep 5 2004: + include + */ + +#include +#include "tisean_cec.h" +#include + +void rescale_data(double *x,unsigned long l,double *min,double *interval) +{ + int i; + + *min=*interval=x[0]; + + for (i=1;i *interval) *interval=x[i]; + } + *interval -= *min; + + if (*interval != 0.0) { + for (i=0;i +#include +#include + +int scan_help(int n,char **in) +{ + int i; + + for (i=1;i +#include +#include +#include +#include "tsa.h" + +char check_col(char *col) +{ + int i; + + for (i=0;i 0) + vcol=check_col(hcol); + *(name+j)='\0'; + break; + } + *(hname+j)=*(name+j); + j++; + } + *col=(unsigned int)atoi(hcol); + free(hname); + free(hcol); + + return vcol; +} + +char* search_datafile(int n,char **names,unsigned int *col, + unsigned int verbosity) +{ + char valid=0,validcol=0; + char *retname=NULL; + int i; + unsigned int hcol; + FILE *test; + + for (i=n-1;i>0;i--) { + if (names[i] != NULL) { + valid=0; + if (strcmp(names[i],"-")) { + if (col != 0) + validcol=look_for_column(names[i],&hcol); + test=fopen(names[i],"r"); + if (test == NULL) { + fprintf(stderr,"File %s not found!\n",names[i]); + } + else { + fclose(test); + if ((col != 0) && (validcol == 1)) + *col=hcol; + if (col != 0) { + if (verbosity&VER_INPUT) + fprintf(stderr,"Using %s as datafile, reading column %u\n", + names[i],*col); + } + else { + if (verbosity&VER_INPUT) + fprintf(stderr,"Using %s as datafile!\n",names[i]); + } + check_alloc(retname=(char*)calloc(strlen(names[i])+1,(size_t)1)); + strcpy(retname,names[i]); + names[i]=NULL; + return retname; + } + } + else { + valid=1; + break; + } + } + } + + if (valid == 1) { + if (verbosity&VER_INPUT) + fprintf(stderr,"Reading input from stdin!\n"); + return NULL; + } + + if (verbosity&VER_INPUT) { + if ((col != 0) && (validcol == 1)) + fprintf(stderr,"Reading input from stdin, using column %u!\n",*col); + else + fprintf(stderr,"Reading input from stdin!\n"); + } + + return NULL; +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/solvele.c b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/solvele.c new file mode 100644 index 0000000..7b198f7 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/solvele.c @@ -0,0 +1,69 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/* Author: Rainer Hegger Last modified: Aug 14th, 1998 */ +#include +#include +#include +#include "tisean_cec.h" + +void solvele(double **mat,double *vec,unsigned int n) +{ + double vswap,*mswap,*hvec,max,h,pivot,q; + int i,j,k,maxi; + + for (i=0;i max) { + max=h; + maxi=j; + } + if (maxi != i) { + mswap=mat[i]; + mat[i]=mat[maxi]; + mat[maxi]=mswap; + vswap=vec[i]; + vec[i]=vec[maxi]; + vec[maxi]=vswap; + } + + hvec=mat[i]; + pivot=hvec[i]; + if (fabs(pivot) == 0.0) { + fprintf(stderr,"Singular matrix! Exiting!\n"); + exit(SOLVELE_SINGULAR_MATRIX); + } + for (j=i+1;j=0;i--) { + hvec=mat[i]; + for (j=n-1;j>i;j--) + vec[i] -= hvec[j]*vec[j]; + vec[i] /= hvec[i]; + } +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/test_outfile.c b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/test_outfile.c new file mode 100644 index 0000000..c46b290 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/test_outfile.c @@ -0,0 +1,35 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger Last modified: Mar 20, 1999 */ +#include +#include +#include "tisean_cec.h" + +void test_outfile(char *name) +{ + FILE *file; + + file=fopen(name,"a"); + if (file == NULL) { + fprintf(stderr,"Couldn't open %s for writing. Exiting\n",name); + exit(TEST_OUTFILE_NO_WRITE_ACCESS); + } + fclose(file); +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/tisean_cec.h b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/tisean_cec.h new file mode 100644 index 0000000..b7c35be --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/tisean_cec.h @@ -0,0 +1,85 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger Last modified: May 26, 2000*/ + +/* These definitions give the exit codes for the C part of the Tisean package. + Typically the name is build up of, first, the name of the routine creating + the exception, secondly, sort of an description of the exception. + */ + +#ifndef _TISEAN_CEC_H +#define _TISEAN_CEC_H + +/* These are the codes for the routines subtree */ +#define RESCALE_DATA_ZERO_INTERVAL 11 +#define CHECK_ALLOC_NOT_ENOUGH_MEMORY 12 +#define CHECK_OPTION_NOT_UNSIGNED 13 +#define CHECK_OPTION_NOT_INTEGER 14 +#define CHECK_OPTION_NOT_FLOAT 15 +#define CHECK_OPTION_NOT_TWO 16 +#define CHECK_OPTION_C_NO_VALUE 17 +#define TEST_OUTFILE_NO_WRITE_ACCESS 18 +#define SOLVELE_SINGULAR_MATRIX 19 +#define GET_SERIES_NO_LINES 20 +#define GET_MULTI_SERIES_WRONG_TYPE_OF_C 21 +#define GET_MULTI_SERIES_NO_LINES 22 +#define VARIANCE_VAR_EQ_ZERO 23 +#define EIG2_TOO_MANY_ITERATIONS 24 +#define CHECK_OPTION_NOT_THREE 25 + +/* These are the codes for the main routines */ +#define LYAP_SPEC_NOT_ENOUGH_NEIGHBORS 50 +#define LYAP_SPEC_DATA_TOO_SHORT 51 +#define AR_MODEL_TOO_MANY_POLES 52 +#define EXTREMA_STRANGE_COMPONENT 53 +#define FALSE_NEAREST_NOT_ENOUGH_POINTS 54 +#define FSLE__TOO_LARGE_MINEPS 55 +#define GHKSS__TOO_MANY_NEIGHBORS 56 +#define NSTAT_Z__INVALID_STRING_FOR_OPTION 57 +#define NSTAT_Z__NOT_UNSIGNED_FOR_OPTION 58 +#define NSTAT_Z__TOO_LARGE_FOR_OPTION 59 +#define NSTAT_Z__OPTION_NOT_SET 60 +#define NSTAT_Z__TOO_MANY_PIECES 61 +#define NSTEP__ESCAPE_REGION 62 +#define POINCARE__WRONG_COMPONENT 63 +#define POINCARE__OUTSIDE_REGION 64 +#define POLYBACK__WRONG_PARAMETER_FILE 65 +#define POLYNOMP__WRONG_PARAMETER_FILE 66 +#define RESCALE__WRONG_INTERVAL 67 +#define SAV_GOL__UNDERDETERMINED 68 +#define SAV_GOL__TOO_LARGE_DERIVATIVE 69 +#define MAKENOISE__FLAGS_REQUIRED 70 +#define ZEROTH__STEP_TOO_LARGE 71 +#define LYAP_K__MAXITER_TOO_LARGE 72 +#define DELAY_WRONG_FORMAT_F 73 +#define DELAY_DIM_NOT_EQUAL_F_M 74 +#define DELAY_DIM_NOT_EQUAL_F_m 75 +#define DELAY_WRONG_FORMAT_D 76 +#define DELAY_WRONG_NUM_D 77 +#define DELAY_INCONS_d_D 78 +#define DELAY_SMALL_ZERO 79 +#define DELAY_INCONS_m_M 80 +#define ONESTEP_TOO_FEW_POINTS 81 +#define MEM_SPEC_TOO_MANY_POLES 82 + +/* Global stuff */ +#define VECTOR_TOO_LARGE_FOR_LENGTH 100 + +#endif diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/tsa.h b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/tsa.h new file mode 100644 index 0000000..877c391 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/tsa.h @@ -0,0 +1,105 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger Last modified: Sep 3, 1999 */ + +#ifndef _TSA_ROUTINES_H +#define _TSA_ROUTINES_H + +#ifndef _TISEAN_CEC_H +#include "tisean_cec.h" +#endif + +/* size of the string which reads the input data + if your lines are longer than some 500 reals, increase the value + */ +#define INPUT_SIZE 1024 + +/* The possible names of the verbosity levels */ +#define VER_INPUT 0x1 +#define VER_USR1 0x2 +#define VER_USR2 0x4 +#define VER_USR3 0x8 +#define VER_USR4 0x10 +#define VER_USR5 0x20 +#define VER_USR6 0x40 +#define VER_FIRST_LINE 0x80 + +/* Uncomment the variable to get rid of the initial Version message */ +/*#define OMIT_WHAT_I_DO*/ + +#define sqr(x) ((x)*(x)) + +#ifdef __cplusplus +extern "C" { +#endif + +extern int scan_help(int,char**); +extern double *get_series(char *,unsigned long *,unsigned long, + unsigned int,unsigned int); +extern double **get_multi_series(char *,unsigned long *,unsigned long, + unsigned int *,char *,char,unsigned int); +extern void rescale_data(double *,unsigned long,double *,double *); +extern void variance(double *,unsigned long,double *,double *); +extern void make_box(double *,long **,long *,unsigned long, + unsigned int,unsigned int,unsigned int,double); +extern unsigned long find_neighbors(double *,long **,long *,double *, + unsigned long,unsigned int,unsigned int, + unsigned int,double,unsigned long *); +extern char* search_datafile(int, char**,unsigned int*,unsigned int); +extern char* check_option(char**,int,int,int); +extern void solvele(double**,double *,unsigned int); +extern void test_outfile(char*); +extern double** invert_matrix(double**,unsigned int); +extern unsigned long exclude_interval(unsigned long,long,long, + unsigned long*,unsigned long*); +extern void make_multi_box(double **,long **,long *,unsigned long, + unsigned int,unsigned int,unsigned int, + unsigned int,double); + /*only used for nrlazy. Will be removed with nrlazy */ +extern void make_multi_box2(double **,long **,long *,unsigned long, + unsigned int,unsigned int,unsigned int, + unsigned int,double); +extern unsigned long find_multi_neighbors(double **,long **,long *,double **, + unsigned long,unsigned int, + unsigned int,unsigned int, + unsigned int,double,unsigned long *); +extern unsigned int** make_multi_index(unsigned int,unsigned int,unsigned int); + +extern void check_alloc(void *); +extern char* myfgets(char *,int *,FILE *,unsigned int); +extern void what_i_do(char *, char *); +extern double* rand_arb_dist(double *,unsigned long,unsigned long, + unsigned int,unsigned long); + +/* routines from rand.c */ +extern void rnd_init(unsigned long); +extern unsigned long rnd_long(); +extern unsigned long rnd_1279(); +extern unsigned long rnd69069(); +extern double gaussian(double); + +/* routines from eigen.c */ +extern void eigen(double**,unsigned long,double*); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/routines/variance.c b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/variance.c new file mode 100644 index 0000000..b7302d3 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/routines/variance.c @@ -0,0 +1,45 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger Last modified: May 23th, 1998 */ +#include +#include +#include +#include "tisean_cec.h" + +void variance(double *s,unsigned long l,double *av,double *var) +{ + unsigned long i; + double h; + + *av= *var=0.0; + + for (i=0;i +#include +#include +#include + +void what_i_do(char *name,char *text) +{ + fprintf(stderr, "\nTISEAN 3.0.1 (C) R. Hegger, H. Kantz," + " T. Schreiber (1998-2007)\n\n" + "%s: %s\n\n",name,text); +} diff --git a/binaries/src/disembl/Tisean_3.0.1/source_c/sav_gol.c b/binaries/src/disembl/Tisean_3.0.1/source_c/sav_gol.c new file mode 100644 index 0000000..15abbc9 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_c/sav_gol.c @@ -0,0 +1,257 @@ +/* + * This file is part of TISEAN + * + * Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber + * + * TISEAN is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * TISEAN is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with TISEAN; if not, write to the Free Software + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + */ +/*Author: Rainer Hegger. Last modified May 27, 2000 */ +#include +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Savitzky-Golay filter: Filters the data or estimates\n\t\ +filtered derivatives, respectively." + +unsigned long length=ULONG_MAX,exclude=0; +unsigned int dim=1; +char dimset=0; +char *columns=NULL; +unsigned int nf=2,nb=2,power=2,deriv=0; +char *infile=NULL,*outfile=NULL,stdo=1; +unsigned int verbosity=(VER_INPUT|VER_FIRST_LINE); + +double **series; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l datapoints [default is whole file]\n"); + fprintf(stderr,"\t-x exclude # points [default %ld]\n",exclude); + fprintf(stderr,"\t-c columns [default 1]\n"); + fprintf(stderr,"\t-m no. of components [default %d]\n",dim); + fprintf(stderr,"\t-n nb,nf [default %u,%u]\n",nb,nf); + fprintf(stderr,"\t-p power of the polynomial [default %u]\n",power); + fprintf(stderr,"\t-D order of the estimated derivative [default %u]\n",deriv); + fprintf(stderr," \t-o outfile [default 'datafile'.sg; Without -o data" + " is written to stdout]\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + + fprintf(stderr,"\t-h show these options\n"); + fprintf(stderr,"\n"); + exit(0); +} + +void scan_options(int n,char **argv) +{ + char *out; + + if ((out=check_option(argv,n,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(argv,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(argv,n,'c','s')) != NULL) + columns=out; + if ((out=check_option(argv,n,'m','u')) != NULL) { + sscanf(out,"%u",&dim); + dimset=1; + } + if ((out=check_option(argv,n,'n','2')) != NULL) + sscanf(out,"%u,%u",&nb,&nf); + if ((out=check_option(argv,n,'p','u')) != NULL) + sscanf(out,"%u",&power); + if ((out=check_option(argv,n,'D','u')) != NULL) + sscanf(out,"%u",&deriv); + if ((out=check_option(argv,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(argv,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +double** make_coeff(void) +{ + long i,j,k; + double **mat,**imat,**rmat; + + check_alloc(mat=(double**)malloc(sizeof(double*)*(power+1))); + for (i=0;i<=power;i++) + check_alloc(mat[i]=(double*)malloc(sizeof(double)*(power+1))); + check_alloc(rmat=(double**)malloc(sizeof(double*)*(power+1))); + for (i=0;i<=power;i++) + check_alloc(rmat[i]=(double*)malloc(sizeof(double)*(nb+nf+1))); + + for (i=0;i<=power;i++) + for (j=0;j<=power;j++) { + mat[i][j]=0.0; + for (k= -(int)nb;k<=(int)nf;k++) + mat[i][j] += pow((double)k,(double)(i+j)); + } + + imat=invert_matrix(mat,(power+1)); + + for (i=0;i<=power;i++) + for (j=0;j<=(nb+nf);j++) { + rmat[i][j]=0.0; + for (k=0;k<=power;k++) + rmat[i][j] += imat[i][k]*pow((double)(j-(int)nb),(double)k); + } + + for (i=0;i<=power;i++) { + free(mat[i]); + free(imat[i]); + } + free(mat); + free(imat); + + return rmat; +} + +double make_norm(void) +{ + double ret=1.0; + long i; + + for (i=2;i<=deriv;i++) + ret *= (double)i; + + return 1.0/ret; +} + +int main(int argc,char **argv) +{ + char stdi=0; + long i,j,d; + double **coeff,help,norm; + FILE *fout; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); + + if (power >= (nb+nf+1)) { + fprintf(stderr,"With these settings for the -n and -p flags,\nthe" + " system is underdetermined. Exiting\n\n"); + exit(SAV_GOL__UNDERDETERMINED); + } + if (deriv > power) { + fprintf(stderr,"The order of the derivative must not be larger\nthan" + " the power of polynomial. Exiting\n\n"); + exit(SAV_GOL__TOO_LARGE_DERIVATIVE); + } + +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,NULL,verbosity); + if (infile == NULL) + stdi=1; + + if (outfile == NULL) { + if (!stdi) { + check_alloc(outfile=(char*)calloc(strlen(infile)+4,(size_t)1)); + sprintf(outfile,"%s.sg",infile); + } + else { + check_alloc(outfile=(char*)calloc((size_t)9,(size_t)1)); + sprintf(outfile,"stdin.sg"); + } + } + if (!stdo) + test_outfile(outfile); + + if (columns == NULL) + series=(double**)get_multi_series(infile,&length,exclude,&dim,"", + dimset,verbosity); + else + series=(double**)get_multi_series(infile,&length,exclude,&dim, + columns,dimset,verbosity); + + coeff=make_coeff(); + norm=make_norm(); + + if (stdo) { + for (i=0;i +#include +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Estimates the crosscorrelations of two data sets\n\t\ +given as two columns of one file." + +char *columns=NULL,*outfile=NULL,stout=1; +unsigned long length=ULONG_MAX,exclude=0; +long tau=100; +unsigned int verbosity=0xff; +double *array1,*array2; +char *infile=NULL; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [Options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l length [default is whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default 0]\n"); + fprintf(stderr,"\t-c which columns (separated by commas) [default is 1,2]\n"); + fprintf(stderr,"\t-D corrlength [default is 100]\n"); + fprintf(stderr,"\t-o output_file [default is 'datafile'.crc; no -o" + " means stdout]\n"); + fprintf(stderr,"\t-V verbosity level [default is 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + fprintf(stderr,"\n"); + exit(0); +} + +void scan_options(int argc,char **argv) +{ + char *out; + + if ((out=check_option(argv,argc,'l','u')) != NULL) + sscanf(out,"%lu",&length); + if ((out=check_option(argv,argc,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(argv,argc,'c','s')) != NULL) + columns=out; + if ((out=check_option(argv,argc,'D','u')) != NULL) + sscanf(out,"%ld",&tau); + if ((out=check_option(argv,argc,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(argv,argc,'o','o')) != NULL) { + stout=0; + if (strlen(out) > 0) + outfile=out; + } +} + +double corr(long i) +{ + unsigned long count=0; + long j,hi; + double c=0.0; + + for (j=0;j= 0) && (hi < length)) { + count++; + c += array1[j]*array2[hi]; + } + } + return c/(double)count; +} + +int main(int argc,char** argv) +{ + char stdi=0; + long i; + unsigned int dummy=2; + FILE *fout=NULL; + double **both; + double av1,var1,av2,var2; + + if (scan_help(argc,argv)) + show_options(argv[0]); + + scan_options(argc,argv); +#ifndef OMIT_WHAT_I_DO + if (verbosity&VER_INPUT) + what_i_do(argv[0],WID_STR); +#endif + + infile=search_datafile(argc,argv,0L,verbosity); + if (infile == NULL) + stdi=1; + + if (outfile == NULL) { + if (!stdi) { + check_alloc(outfile=(char*)calloc(strlen(infile)+5,(size_t)1)); + strcpy(outfile,infile); + strcat(outfile,".ccr"); + } + else { + check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1)); + strcpy(outfile,"stdin.ccr"); + } + } + if (!stout) + test_outfile(outfile); + + if (columns == NULL) + both=(double**)get_multi_series(infile,&length,exclude,&dummy,"",(char)1, + verbosity); + else + both=(double**)get_multi_series(infile,&length,exclude,&dummy,columns, + (char)1,verbosity); + + array1=both[0]; + array2=both[1]; + + if (tau >= length) + tau=length-1; + + variance(array1,length,&av1,&var1); + variance(array2,length,&av2,&var2); + + for (i=0;i +#include +#include +#include +#include "routines/tsa.h" + +#define WID_STR "Estimates the average cross forecast error for a zeroth\n\t\ +order fit between two series given as two columns of one file." + +#ifndef _MATH_H +#include +#endif + +/*number of boxes for the neighbor search algorithm*/ +#define NMAX 128 + +unsigned int nmax=(NMAX-1); +long **box,*list; +unsigned long *found; +double *series1,*series2; +double interval,min,epsilon; + +char epsset=0; +char *infile=NULL; +char *outfile=NULL,stdo=1; +char *COLUMNS=NULL; +unsigned int DIM=3,DELAY=1; +unsigned int verbosity=0xff; +int MINN=30,STEP=1; +double EPS0=1.e-3,EPSF=1.2; +unsigned long LENGTH=ULONG_MAX,exclude=0,CLENGTH=ULONG_MAX; + +void show_options(char *progname) +{ + what_i_do(progname,WID_STR); + fprintf(stderr," Usage: %s [options]\n",progname); + fprintf(stderr," Options:\n"); + fprintf(stderr,"Everything not being a valid option will be interpreted" + " as a possible" + " datafile.\nIf no datafile is given stdin is read. Just - also" + " means stdin\n"); + fprintf(stderr,"\t-l # of data to use [default: whole file]\n"); + fprintf(stderr,"\t-x # of lines to be ignored [default: 0]\n"); + fprintf(stderr,"\t-c columns to read [default: 1,2]\n"); + fprintf(stderr,"\t-m embedding dimension [default: 3]\n"); + fprintf(stderr,"\t-d delay [default: 1]\n"); + fprintf(stderr,"\t-n # of reference points [default: length]\n"); + fprintf(stderr,"\t-k minimal number of neighbors for the fit " + "[default: 30]\n"); + fprintf(stderr,"\t-r neighborhoud size to start with " + "[default: (data interval)/1000]\n"); + fprintf(stderr,"\t-f factor to increase size [default: 1.2]\n"); + fprintf(stderr,"\t-s steps to forecast [default: 1]\n"); + fprintf(stderr,"\t-o output file [default: 'datafile.cze'," + " without -o: stdout]\n"); + fprintf(stderr,"\t-V verbosity level [default: 1]\n\t\t" + "0='only panic messages'\n\t\t" + "1='+ input/output messages'\n"); + fprintf(stderr,"\t-h show these options\n"); + exit(0); +} + +void scan_options(int n,char **in) +{ + char *out; + + if ((out=check_option(in,n,'l','u')) != NULL) + sscanf(out,"%lu",&LENGTH); + if ((out=check_option(in,n,'x','u')) != NULL) + sscanf(out,"%lu",&exclude); + if ((out=check_option(in,n,'c','s')) != NULL) + COLUMNS=out; + if ((out=check_option(in,n,'m','u')) != NULL) + sscanf(out,"%u",&DIM); + if ((out=check_option(in,n,'d','u')) != NULL) + sscanf(out,"%u",&DELAY); + if ((out=check_option(in,n,'n','u')) != NULL) + sscanf(out,"%lu",&CLENGTH); + if ((out=check_option(in,n,'k','u')) != NULL) + sscanf(out,"%u",&MINN); + if ((out=check_option(in,n,'r','f')) != NULL) { + epsset=1; + sscanf(out,"%lf",&EPS0); + } + if ((out=check_option(in,n,'f','f')) != NULL) + sscanf(out,"%lf",&EPSF); + if ((out=check_option(in,n,'s','u')) != NULL) + sscanf(out,"%u",&STEP); + if ((out=check_option(in,n,'V','u')) != NULL) + sscanf(out,"%u",&verbosity); + if ((out=check_option(in,n,'o','o')) != NULL) { + stdo=0; + if (strlen(out) > 0) + outfile=out; + } +} + +double make_fit(unsigned long act,unsigned long number,unsigned long istep) +{ + double casted=0.0; + int i; + + for (i=0;i= MINN) { + for (j=1;j<=STEP;j++) + error[j-1] += make_fit(i,actfound,j); + done[i]=1; + } + alldone &= done[i]; + } + } + if (stdo) { + if (verbosity&VER_INPUT) + fprintf(stderr,"Writing to stdout\n"); + for (i=0;i istdio.f + $(FC) $(FFLAGS) -c istdio.f -o istdio.o + +$(BINS): libtsa.a libsla.a *.f + -$(FC) $(FFLAGS) -o $@ $@.f $(LOADLIBES) $(LDFLAGS) + +libtsa.a: $(INC) + $(AR) $(ARFLAGS) libtsa.a $? + $(RANLIB) libtsa.a + +libsla.a: slatec/*.f + (cd slatec && $(MAKE)) + +Randomize: libtsa.a libsla.a + -(cd randomize && $(MAKE)) + +clean: + @rm -f istdio.f + @rm -f $(BINS) + -(cd randomize && $(MAKE) clean) + +install: $(BINS) + -for bin in $(BINS); do $(INSTALL) $$bin $(BINDIR); done + -(cd randomize && $(MAKE) $@) + +missing: + -@for bin in $(BINS); do \ + test -z "`$$bin -h 2>&1 | grep Usage`" \ + && echo $$bin "(Wuppertal Fortran)" >> ../missing.log; \ + $$bin -h 2>&1 | cat >> ../install.log; \ + done; : + -@(cd randomize && $(MAKE) $@) + +uninstall: + -@for bin in $(BINS); do rm -f $(BINDIR)/$$bin; done + -@(cd randomize && $(MAKE) $@) diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/addnoise.f b/binaries/src/disembl/Tisean_3.0.1/source_f/addnoise.f new file mode 100644 index 0000000..e269327 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/addnoise.f @@ -0,0 +1,102 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c addnoise.f +c +c add Gaussian / uniform white noise +c author T. Schreiber (1998) +c=========================================================================== + + parameter(nx=1000000) + character*72 file, fout + dimension x(nx) + external rand + data eps/0./, frac/0./, iuni/0/ + data iverb/1/ + + call whatido("add Gaussian/uniform noise",iverb) + eps=fcan("r",eps) + frac=fcan("v",frac) + nmaxx=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + if(lopt("u",1).eq.1) iuni=1 + isout=igetout(fout,iverb) + if(eps.eq.0.and.frac.eq.0.) call usage() + + if(lopt("0",1).eq.1.and.eps.gt.0) then + if(isout.eq.1) fout="0_noisy" + do 10 n=1,nmaxx + if(iuni.eq.1) then + x(n)=rand(0.0)*eps + else + x(n)=rgauss(0.0,eps) + endif + 10 continue + call writefile(nmaxx,x,fout,iverb) + stop + endif + + do 20 ifi=1,nstrings() + call nthstring(ifi,file) + nmax=nmaxx + call readfile(nmax,x,nexcl,jcol,file,iverb) + if(file.eq."-") file="stdin" + call rms(nmax,x,sc,sd) + if(frac.gt.0) eps=sd*frac + if(iuni.eq.1) then + if(iv_io(iverb).eq.1) write(istderr(),*) + . "adding uniform noise in [0,", eps,"]" + else + if(iv_io(iverb).eq.1) write(istderr(),*) + . "adding Gaussian noise of amplitude", eps + endif + if(sd.gt.0.and.iv_io(iverb).eq.1) write(istderr(),*) + . "that is",eps/sd,"* rms of data" + do 30 n=1,nmax + if(iuni.eq.1) then + x(n)=x(n)+rand(0.0)*eps + else + x(n)=x(n)+rgauss(0.0,eps) + endif + 30 continue + if(isout.eq.1) call addsuff(fout,file,"_noisy") + 20 call writefile(nmax,x,fout,iverb) + end + + subroutine usage() +c usage message + + call whatineed( + . "[-r# | -v#] [-u -0 -o outfile -l# -x# -c# -V# -h] file(s)") + call ptext("either -r or -v must be present") + call popt("r","absolute noise level") + call popt("v","same as fraction of standard deviation") + call popt("u","add uniform noise (default Gaussian)") + call popt("0","do not read input, just issue random numbers") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_noisy") + call pall() + stop + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/any_s.f b/binaries/src/disembl/Tisean_3.0.1/source_f/any_s.f new file mode 100644 index 0000000..ff8f9cc --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/any_s.f @@ -0,0 +1,43 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c any_s.f +c extract numbers from strings +c author T. Schreiber (1998) +c=========================================================================== + + function i_s(s,ierr) + character*(*) s + + ierr=0 + read(s,'(i20)',err=777) i_s + if(s.ne.'-'.and.s.ne.'+') return ! reject a solitary - or + + 777 ierr=1 + end + + function f_s(s,ierr) + character*(*) s + + ierr=0 + read(s,'(f20.0)',err=777) f_s + if(s.ne.'-'.and.s.ne.'+') return ! reject a solitary - or + + 777 ierr=1 + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/ar-run.f b/binaries/src/disembl/Tisean_3.0.1/source_f/ar-run.f new file mode 100644 index 0000000..e4f3588 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/ar-run.f @@ -0,0 +1,99 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c ar-run.f +c iterate AR model, e.g. as fitted by ar-model (Dresden) +c author T. Schreiber (1999) +c=========================================================================== + + parameter(npmax=100) + character*72 file, fout, fline + dimension x(-npmax:npmax), a(npmax) + external rand + data np/npmax/, ntrans/10000/, iuni/0/ + data iverb/1/ + + call whatido("iterate AR model, e.g. as fitted by ar-model",iverb) + np=ican("p",np) + if(np.gt.npmax) stop "ar-run: make npmax larger." + nmax=imust('l') + ntrans=ican("x",ntrans) + if(lopt("u",1).eq.1) iuni=1 + r=rand(sqrt(abs(fcan("I",0.0)))) + isout=igetout(fout,iverb) + + do 10 n=1,npmax + x(-n)=0. + 10 x(n)=0. + call nthstring(1,file) + call infile(file,iunit,iverb) + read(iunit,'(a)') fline + if(fline(1:1).eq."#") then + read(fline(18:72),'(f20.0)',err=999) var + do 20 j=1,np + read(iunit,'(a1,f20.0)',err=999) fline(1:1), a(j) + 20 if(fline(1:1).ne."#") goto 1 + else + read(fline(1:72),'(f20.0)',err=999) var + do 30 j=1,np + 30 read(iunit,'(f20.0)',err=999,end=1) a(j) + endif + 1 np=j-1 + if(iv_echo(iverb).eq.1) then + write(istderr(),*) 'coefficients: ', (a(i),i=1,np) + write(istderr(),*) 'driving amplitude: ', var + endif + if(isout.eq.1) fout="ar.dat" + call outfile(fout,iunit,iverb) + n=-ntrans + 2 n=n+1 + nn=mod(n+ntrans,np)+1 + xx=rgauss(0.0,var) + do 40 j=1,np + 40 xx=xx+a(j)*x(nn-j) + x(nn)=xx + x(nn-np)=xx + if(n.lt.1) goto 2 + write(iunit,*) xx + if(nmax.eq.0.or.n.lt.nmax) goto 2 + stop + + 999 write(istderr(),'(a)') "wrong input format! try:" + write(istderr(),'(a)') "(rms of increments)" + write(istderr(),'(a)') "a(1)" + write(istderr(),'(a)') "a(2)" + write(istderr(),'(a)') "..." + end + + subroutine usage() +c usage message + + call whatineed( + . "-l# [-p# -I# -o outfile -x# -V# -h] file") + call popt("l","number of iterations (l=0: infinite)") + call popt("p","order of AR-model (default determined from input)") + call popt("I","seed for random numbers") + call popt("x","number of transients discarded (10000)") + call pout("ar.dat") + call pall() + stop + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/arguments.f b/binaries/src/disembl/Tisean_3.0.1/source_f/arguments.f new file mode 100644 index 0000000..82cf80a --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/arguments.f @@ -0,0 +1,159 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c arguments.f +c get command line arguments +c author T. Schreiber (1998) +c=========================================================================== + + subroutine argdel(i) + parameter(margs=1000) + dimension largs(margs) + common /args/ nargs, largs + + if(i.eq.0) then + nargs=min(margs,iargc()) + do 10 n=1,nargs + 10 largs(n)=1 + else + if(i.gt.iargc()) return + if(largs(i).eq.0) return + largs(i)=0 + nargs=nargs-1 + endif + end + + function nstrings() + parameter(margs=1000) + dimension largs(margs) + common /args/ nargs, largs + + nstrings=max(nargs,1) + end + + subroutine nthstring(n,string) + parameter(margs=1000) + dimension largs(margs) + common /args/ nargs, largs + character*(*) string + + iv=0 + do 10 i=1,iargc() + if(largs(i).eq.1) iv=iv+1 + 10 if(iv.eq.n) goto 1 + string="-" + return + 1 call getarg(i,string) + end + + function imust(c) +c get mandatory integer argument, call usage statement if missing + character c + + imust=iopt(c,1,ierr) + if(ierr.ne.0) call usage() + end + + function fmust(c) +c get mandatory real argument, call usage statement if missing + character c + + fmust=fopt(c,1,ierr) + if(ierr.ne.0) call usage() + end + + subroutine smust(c,string) +c get mandatory string argument, call usage statement if missing + character c + character*(*) string + + call sopt(c,1,string,ierr) + if(ierr.ne.0) call usage() + end + + function ican(c,idef) +c get optional integer argument, provide default if missing + character c + + ican=iopt(c,1,ierr) + if(ierr.ne.0) ican=idef + end + + function fcan(c,fdef) +c get optional real argument, provide default if missing + character c + + fcan=fopt(c,1,ierr) + if(ierr.ne.0) fcan=fdef + end + + subroutine stcan(c,string,dstring) +c get optional string argument, provide default if missing + character c + character*(*) string, dstring + + call sopt(c,1,string,ierr) + if(ierr.ne.0) string=dstring + end + + function igetout(fout,iverb) +c gets alternate output file name, default " " +c return 1 if fout must be determined from input file name + character*(*) fout + + igetout=0 + call stcan("o",fout," ") + if(fout.ne." ".and.nstrings().gt.1.and.iv_io(iverb).ne.0) + . write(istderr(),*) '*** single output file for multiple'// + . ' input files - results may be overwritten' + if(fout.ne." ") return + igetout=lopt("o",1) + end + + subroutine imcan(c,mmax,mc,ilist) +c get optional integer argument with multiple comma separated values + character c + character*72 string + dimension ilist(*) + + call stcan(c,string," ") + string(index(string," "):index(string," "))="," + do 10 m=1,mmax + if(index(string,",").le.1) goto 1 + read(string(1:index(string,",")-1),*,err=1,end=1) ilist(m) + 10 string=string(index(string,",")+1:72) + 1 mc=m-1 + end + + subroutine fmcan(c,mmax,mc,flist) +c get optional real argument with multiple comma separated values + character c + character*72 string + dimension flist(*) + + call stcan(c,string," ") + string(index(string," "):index(string," "))="," + do 10 m=1,mmax + if(index(string,",").le.1) goto 1 + read(string(1:index(string,",")-1),*,err=1,end=1) flist(m) + 10 string=string(index(string,",")+1:72) + 1 mc=m-1 + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/autocor.f b/binaries/src/disembl/Tisean_3.0.1/source_f/autocor.f new file mode 100644 index 0000000..e8af066 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/autocor.f @@ -0,0 +1,96 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c autocor.f +c autocorrelation function through FFT +c author T. Schreiber (1998), H. Kantz (2007) +c=========================================================================== + + parameter(nx=1000000) + dimension x(2*nx) + character*72 file, fout + data iverb/1/ + + call whatido("autocorrelation function estimated by FFT",iverb) + ivar=lopt('v',1) + iper=lopt('p',1) + iexact=lopt('P',1) + if(iexact.ne.0) iper=1 + nmaxx=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + isout=igetout(fout,iverb) + + do 10 ifi=1,nstrings() + call nthstring(ifi,file) + nmax=nmaxx + call readfile(nmax,x,nexcl,jcol,file,iverb) + if(file.eq."-") file="stdin" + if(ivar.eq.0) call normal(nmax,x,sc,sd) + if(iper.eq.0) then + nmaxp=nmore(2*nmax) + do 20 n=nmax+1,nmaxp + 20 x(n)=0. + call store_spec(nmaxp,x,1) + do 30 n=1,nmax + 30 x(n)=x(n)/real(nmax-n+1) + else + nmaxp=nmax + if(iexact.eq.0) then + nmaxp=nless(nmax) + if(nmaxp.ne.nmax.and.iv_io(iverb).eq.1) + . write(istderr(),*) "autocor: using", nmaxp + endif + call store_spec(nmaxp,x,1) + do 50 n=1,nmaxp + 50 x(n)=x(n)/real(nmaxp) + endif + if(isout.eq.1) call addsuff(fout,file,"_co") + call outfile(fout,iunit,iverb) + if(ivar.eq.0) then + if(sd.eq.0) stop "autocor: cannot normalise - zero variance" + fsc=1./x(1) + else + fsc=1. + endif + do 60 n=1,min(nmax,nmaxp) + 60 write(iunit,*) n-1, fsc*x(n) + 10 if(iunit.ne.istdout()) close(iunit) + end + + subroutine usage() +c usage message + + call whatineed( + . "[-v -p -P -o outfile -l# -x# -c# -V# -h] file(s)") + call popt("v","give unnormalised autocovariance") + call popt("p","assume periodic continuation") + call popt("P","assume periodic continuation exactly") + call popt("l","number of values to be read [all]") + call popt("x","number of values to be skipped [0]") + call popt("c","column to be read [1 or file,#]") + call pout("file_co") + call pall() + stop + end + + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/c1.f b/binaries/src/disembl/Tisean_3.0.1/source_f/c1.f new file mode 100644 index 0000000..e770046 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/c1.f @@ -0,0 +1,92 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c information dimension, fixed mass +c see H. Kantz, T. Schreiber, Nonlinear Time Series Analysis, Cambridge +c University Press (1997) +c author T. Schreiber (1999) +c=========================================================================== + + parameter(nx=100000,mx=10) + dimension x(nx,mx), icol(mx) + character*72 file, fout + data kmax/100/, res/2./ + data iverb/1/ + external rand + + call whatido("fixed mass approach to d1 estimation",iverb) + id=imust("d") + mfrom=imust("m") + mto=imust("M") + ntmin=imust("t") + ncmin=imust("n") + res=fcan("#",res) + r=rand(sqrt(abs(fcan("I",0.0)))) + kmax=ican("K",kmax) + resl=log(2.)/res + nmax=ican("l",nx) + nexcl=ican("x",0) + call columns(mc,mx,icol) + mcmax=max(1,mc) + isout=igetout(fout,iverb) + if(fout.eq." ") isout=1 + + call nthstring(1,file) + call xreadfile(nmax,mcmax,nx,x,nexcl,icol,file,iverb) + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_c1") + call outfile(fout,iunit,iverb) + do 10 m=mfrom,mto + write(iunit,'(4h#m= ,i5)') m + pr=0. + do 20 pl=log(1./(nmax-(m-1)*id)),0.,resl + pln=pl + call d1(nmax,mcmax,nx,x,id,m,ncmin,pr,pln,rln,ntmin,kmax) + if(pln.eq.pr) goto 20 + it=it+1 + pr=pln + write(iunit,*) exp(rln), exp(pln) + 20 continue + write(iunit,'()') + 10 write(iunit,'()') + end + + subroutine usage() +c usage message + + call whatineed( + . "-d# -m# -M# -t# -n# "// + . "[-## -K# -o outfile -I# -l# -x# -c#,# -V# -h] file") + call popt("d","delay") + call popt("m","minimal total embedding dimension") + call popt("M","maximal total embedding dimension") + call popt("t","minimal time separation") + call popt("n","minimal number of center points") + call popt("#","resolution, values per octave (2)") + call popt("K","maximal number of neighbours (100)") + call popt("I","seed for random numbers") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column(s) to be read (1 or file,#)") + call pout("file_c1") + call pall() + stop + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/c2d.f b/binaries/src/disembl/Tisean_3.0.1/source_f/c2d.f new file mode 100644 index 0000000..a48eda2 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/c2d.f @@ -0,0 +1,90 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c c2d.f +c local slopes from c2 +c author T. Schreiber (1998) +c=========================================================================== + + parameter(meps=1000) + dimension e(meps), c(meps) + character*72 file, fout, aline + data iav/1/ + data iverb/1/ + + call whatido("local slopes from c1/c2 correlation sum data",iverb) + iav=ican('a',iav) + isout=igetout(fout,iverb) + if(nstrings().eq.0) call usage() + call nthstring(1,file) + call infile(file,iunit,iverb) + if(isout.eq.1) call addsuff(fout,file,"_d") + call outfile(fout,iunit2,iverb) + 1 read(iunit,'(a)',end=999) aline + 4 if(aline(1:1).ne."#") goto 1 + if(aline(1:1).eq."#") + . read(aline(index(aline,"m=")+2:72),'(i20)',err=1) m + me=0 + 2 read(iunit,'(a)') aline + if(aline(1:72).eq." ") goto 3 + read(aline,*,err=999,end=999) ee, cc + if(cc.le.0.) goto 3 + me=me+1 + e(me)=log(ee) + c(me)=log(cc) + goto 2 + 3 write(iunit2,'(4h#m= ,i5)') m + do 30 j=iav+1,me-iav + call slope(e(j-iav),c(j-iav),2*iav+1,s) + 30 if(s.gt.0.) write(iunit2,*) exp(0.5*(e(j+iav)+e(j-iav))), s + write(iunit2,'()') + write(iunit2,'()') + goto 4 + 999 stop + end + + subroutine slope(x,y,n,a) + dimension x(n),y(n) + + sx=0. + sa=0 + a=0. + do 10 i=1,n + 10 sx=sx+x(i) + do 20 i=1,n + sa=sa+(x(i)-sx/n)**2 + 20 a=a+y(i)*(x(i)-sx/n) + a=a/sa + end + + + subroutine usage() +c usage message + + call whatineed( + . "[-a# -o outfile -V# -h] file") + call popt("a","average using -#,...,+# [1]") + call pout("file_d") + call pall() + stop + end + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/c2g.f b/binaries/src/disembl/Tisean_3.0.1/source_f/c2g.f new file mode 100644 index 0000000..2c7a4c0 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/c2g.f @@ -0,0 +1,109 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c c2g.f +c Gaussian kernel correlation integral from c2 +c author T. Schreiber (1998) +c=========================================================================== + parameter(meps=1000) + dimension e(meps), c(meps), lw(meps) + character*72 file, fout, aline + double precision g,gd,h,d,f,func,gg,ggd,err,dum1,dum2,a,b,dc,de + external func, funcd + common h,d,f + data iverb/1/ + + call whatido("Gaussian kernel correlation sum from c2",iverb) + isout=igetout(fout,iverb) + if(nstrings().eq.0) call usage() + call nthstring(1,file) + call infile(file,iunit,iverb) + if(isout.eq.1) call addsuff(fout,file,"_g") + call outfile(fout,iunit2,iverb) + 1 read(iunit,'(a)',end=999) aline + 4 if(aline(1:1).ne."#") goto 1 + if(aline(1:1).eq."#") + . read(aline(index(aline,"m=")+2:72),'(i20)',err=1) m + me=0 + 2 read(iunit,'(a)') aline + if(aline(1:72).eq." ") goto 3 + me=me+1 + read(aline,*,err=999,end=999) ee, cc + if(cc.le.0.) goto 3 + e(me)=log(ee) + c(me)=log(cc) + goto 2 + 3 write(iunit2,'(4h#m= ,i5)') m + call indexx(me,e,lw) + call index2sort(me,e,lw) + call index2sort(me,c,lw) + do 10 j=1,me + h=exp(e(j)) + g=0 + gd=0 + do 20 k=1,me-1 + f=exp((e(k+1)*c(k)-e(k)*c(k+1))/(e(k+1)-e(k))) + d=(c(k+1)-c(k))/(e(k+1)-e(k)) + a=e(k) + b=e(k+1) + gg=0. + ggd=0. + if(b.ne.a) call dqk15(func,a,b,gg,err,dum1,dum2) + if(b.ne.a) call dqk15(funcd,a,b,ggd,err,dum1,dum2) + g=g+gg + 20 gd=gd+ggd + dc=c(me) + de=e(me) + cgauss=g/(h**2)+exp(-exp(2*de)/(2*h**2)) + cgd=gd/(h**4)+(2+exp(2*de)/h**2)*exp(-exp(2*de)/(2*h**2)) + 10 write(iunit2,*) h, cgauss, -2+cgd/cgauss + write(iunit2,'()') + write(iunit2,'()') + goto 4 + 999 stop + end + + double precision function func(u) + double precision h,d,f,u + common h,d,f + + func=f*exp((2+d)*u-exp(2*u)/(2*h**2)) + end + + double precision function funcd(u) + double precision h,d,f,u + common h,d,f + + funcd=f*exp((4+d)*u-exp(2*u)/(2*h**2)) + end + + subroutine usage() +c usage message + + call whatineed( + . "[-o outfile -V# -h] file") + call pout("file_g") + call pall() + stop + end + + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/c2naive.f b/binaries/src/disembl/Tisean_3.0.1/source_f/c2naive.f new file mode 100644 index 0000000..9c023b0 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/c2naive.f @@ -0,0 +1,120 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c c2naive.f +c correlation integral c2, no fast neighbour search +c complete direct neighbour search +c author T. Schreiber (1998) +c modified H. Kantz, Feb. 2007 +c=========================================================================== + + parameter(nx=1000000,me=30,meps=800) + dimension x(nx), c(0:meps,me) +c j=a*(log(d)-log(xmax-xmin)) d=xmax-xmin -> j=0 +c a=-rs/log(2.) d=s*2**(-j/res) + character*72 file, fout + data res/2./ + data iverb/1/ + + call whatido("correlation sum, complete naive neighbour search, + .univariate data only" + . ,iverb) + call whatido("univariate data only",iverb) + id=imust("d") + mmax=imust("M") + mmin=ican("m",1) + ntmin=imust("t") + ntmax=ican("T",nx) + res=fcan("#",res) + nmaxx=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + isout=igetout(fout,iverb) + if(fout.eq." ") isout=1 + + do 10 ifi=1,nstrings() + call nthstring(ifi,file) + nmax=nmaxx + call readfile(nmax,x,nexcl,jcol,file,iverb) + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_c2") + call minmax(nmax,x,xmin,xmax) + sc=xmax-xmin + a=-res/log(2.) + do 20 m=mmin,mmax + do 20 j=0,meps + 20 c(j,m)=0. + call d2naive(nmax,x,id,mmin,mmax,c,meps,log(sc),a,ntmin,ntmax) + call outfile(fout,iunit,iverb) + do 30 m=mmin,mmax + write(iunit,'(4h#m= ,i5)') m + do 40 j=meps-1,0,-1 + 40 c(j,m)=c(j,m)+c(j+1,m) + do 50 j=0,meps + if(c(j,m).eq.0.) goto 1 + 50 write(iunit,*) sc*2**(-j/res), c(j,m)/c(0,m) + 1 write(iunit,'()') + 30 write(iunit,'()') + close(iunit) + 10 continue + end + + subroutine usage() +c usage message + + call whatineed( + . "-d# -M# -t# [-m# -##"// + . " -o outfile -l# -x# -c# -V# -h] file(s)") + call popt("d","delay") + call popt("M","maximal embedding dimension") + call popt("t","minimal time separation") + call popt("m","minimal embedding dimension [1]") + call popt("#","resolution, values per octave [2]") +c call popt("T","for Guido") + call popt("l","number of values to be read [all]") + call popt("x","number of values to be skipped [0]") + call popt("c","column to be read [1 or file,#]") + call pout("file_c2") + call pall() + stop + end + + subroutine d2naive(nmax,x,id,mmin,mmax,c,meps,scl,a,ntmin,ntmax) + parameter(nx=1000000,tiny=1e-30) + dimension x(nmax),c(0:meps,mmax),d(nx) + + if(nmax.gt.nx) stop "d2naive: make nx larger." + nlast=min(nmax-(mmax-1)*id-1,ntmax) + do 10 ndt=ntmin,nlast + do 20 n=ndt+1,nmax + 20 d(n)=max(abs(x(n)-x(n-ndt)),tiny) + do 10 n=ndt+1+(mmax-1)*id,nmax + dmax=d(n) + do 30 m=2,mmin-1 + 30 dmax=max(dmax,d(n-(m-1)*id)) + j=int(a*(log(dmax)-scl)) + do 10 m=mmin,mmax + if(d(n-(m-1)*id).gt.dmax) then + dmax=d(n-(m-1)*id) + j=int(a*(log(dmax)-scl)) + endif + 10 c(j,m)=c(j,m)+1 + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/c2t.f b/binaries/src/disembl/Tisean_3.0.1/source_f/c2t.f new file mode 100644 index 0000000..d9ef6e7 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/c2t.f @@ -0,0 +1,81 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c c2t.f +c Takens' estimator from c2 +c author T. Schreiber (1998) +c=========================================================================== + + parameter(meps=1000) + dimension e(meps), c(meps), lw(meps) + double precision a, b + character*72 file, fout, aline + data iverb/1/ + + call whatido("Takens' estimator from correlation sum data",iverb) + isout=igetout(fout,iverb) + if(nstrings().eq.0) call usage() + call nthstring(1,file) + call infile(file,iunit,iverb) + if(isout.eq.1) call addsuff(fout,file,"_t") + call outfile(fout,iunit2,iverb) + 1 read(iunit,'(a)',end=999) aline + 4 if(aline(1:1).ne."#") goto 1 + if(aline(1:1).eq."#") + . read(aline(index(aline,"m=")+2:72),'(i20)',err=1) m + me=0 + 2 read(iunit,'(a)') aline + if(aline(1:72).eq." ") goto 3 + read(aline,*,err=999,end=999) ee, cc + if(cc.le.0.) goto 3 + me=me+1 + e(me)=log(ee) + c(me)=log(cc) + goto 2 + 3 write(iunit2,'(4h#m= ,i5)') m + call indexx(me,e,lw) + call index2sort(me,e,lw) + call index2sort(me,c,lw) + cint=0 + do 10 i=2,me + b=(e(i)*c(i-1)-e(i-1)*c(i))/(e(i)-e(i-1)) + a=(c(i)-c(i-1))/(e(i)-e(i-1)) + if(a.ne.0) then + cint=cint+(exp(b)/a)*(exp(a*e(i))-exp(a*e(i-1))) + else + cint=cint+exp(b)*(e(i)-e(i-1)) + endif + 10 write(iunit2,*) exp(e(i)), exp(c(i))/cint + write(iunit2,'()') + write(iunit2,'()') + goto 4 + 999 stop + end + + subroutine usage() +c usage message + + call whatineed( + . "[-o outfile -V# -h] file") + call pout("file_t") + call pall() + stop + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/choose.f b/binaries/src/disembl/Tisean_3.0.1/source_f/choose.f new file mode 100644 index 0000000..5795c27 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/choose.f @@ -0,0 +1,60 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c choose.f +c Choose columns and sub-sequences from a file +c author T. Schreiber (1999) +c=========================================================================== + + parameter(nx=1000000,mx=5) + dimension x(nx,mx), icol(mx) + character*72 file, fout + data iverb/15/ + + call whatido("Choose columns and sub-sequences from a file",iverb) + nmax=ican("l",nx) + nexcl=ican("x",0) + mcmax=ican("m",0) + call columns(mc,mx,icol) + if(mcmax.eq.0) mcmax=max(1,mc) + isout=igetout(fout,iverb) + + call nthstring(1,file) + call xreadfile(nmax,mcmax,nx,x,nexcl,icol,file,iverb) + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_select") + call outfile(fout,iunit,iverb) + call xwritefile(nmax,mcmax,nx,x,fout,iverb) + end + + subroutine usage() +c usage message + + call whatineed( + . "[-o outfile -l# -x# -m# -c#[,#] -V# -h] file") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("m","number of columns to be read (1)") + call popt("c","columns to be read (1)") + call pout("file_select") + call pall() + stop + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/cluster.f b/binaries/src/disembl/Tisean_3.0.1/source_f/cluster.f new file mode 100644 index 0000000..61357ff --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/cluster.f @@ -0,0 +1,195 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c clustering a dissimilarity matrix +c see Schreiber and Schmitz, Phys. Rev. Lett. 79 (1997) 1475 +c author T. Schreiber (1998) +c=========================================================================== + + parameter(npmax=1000) + dimension d(npmax,npmax), iu(npmax), ifix(npmax) + character*72 file, fout, filex + data iverb/3/ + + call whatido("clustering a dissimilarity matrix",iverb) + ncl=imust("#") + iflag=lopt("=",1) + call stcan('X',filex,' ') + isout=igetout(fout,iverb) + + call nthstring(1,file) + call infile(file,iunit,iverb) + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_clust") + do 10 i=1,npmax + do 10 j=1,npmax + 10 d(i,j)=-1e20 + np=0 + 1 read(iunit,*,end=999) i,j,dij + d(i,j)=dij + np=max(i,j,np) + goto 1 + 999 if(iv_io(iverb).eq.1) write(0,'(a,i)') "matrix size ", np + dmean=0 + nd=0 + do 20 i=1,np + do 20 j=1,np + if(d(i,j).ne.-1e20) then + nd=nd+1 + dmean=dmean+d(i,j) + endif + 20 continue + do 30 i=1,np + do 30 j=1,np + 30 if(d(i,j).eq.-1e20) d(i,j)=dmean/nd + do 40 i=1,np + 40 ifix(i)=0 + if(filex.ne." ") then + open(10,file=filex,status='old',err=998) + nfix=0 + 2 read(10,*,end=998,err=2) i, iff + if(i.lt.1.or.i.gt.np.or.iff.gt.ncl.or.iff.lt.1) goto 1 + ifix(i)=iff + nfix=nfix+1 + endif + 998 if(nfix.eq.np) stop "all fixed." + call clustering(np,d,npmax,ncl,nfix,ifix,iu,iverb,iflag) + call outfile(fout,iunit,iverb) + do 50 n=1,np + 50 write(iunit,*) iu(n), (costi(np,iu,d,n,ic,iflag),ic=1,ncl) + end + + subroutine usage() +c usage message + + call whatineed("-## [-= -X xfile] file") + call popt("#","number of clusters") + call popt("=","if set, bias towards similar size clusters") + call popt("X","list of indices with fixed cluster assignments") + call pout("file_clust") + call pall() + call ptext("Verbosity levels (add what you want):") + call ptext(" 1 = input/output" ) + call ptext(" 2 = state of clustering") + call ptext(" 8 = temperature / cost at cooling") + stop + end + + subroutine clustering(np,d,npmax,ncl,nfix,ifix,iu,iverb,iflag) + parameter(nt0=20,tfac=10.,tstep=0.99,ntotmaxf=20,nsuccmaxf=2) + external rand + character*1 c + dimension d(npmax,npmax), iu(*), ifix(*) + equivalence (c,ic) + data c/'A'/ + + ntotmax=(np-nfix)*ntotmaxf + nsuccmax=(np-nfix)*nsuccmaxf + se=0. + se2=0. + do 10 nt=1,nt0 + call ranconf(np,iu,ncl,ifix) + e=cost(np,iu,d,ncl,iflag) + se=se+e + 10 se2=se2+e**2 + t=tfac*sqrt(se2/nt0-(se/nt0)**2) + + ntot=0 + nsucc=0 + 1 call cconf(np,iu,ncl,nch,iuold,ifix) + ec=cost(np,iu,d,ncl,iflag) + ntot=ntot+1 + if(ec.lt.e.or.(rand(0.0).lt.exp(-(ec-e)/t))) then + e=ec + nsucc=nsucc+1 + else + iu(nch)=iuold + endif + if(ntot.eq.ntotmax .or. nsucc.eq.nsuccmax) then + if(nsucc.eq.0) return + ntot=0 + nsucc=0 + if(iv_clust(iverb).eq.1) write(istderr(),'(80a1)') + . (ic+iu(n)-1,n=1,np) + if(iv_cool(iverb).eq.1) write(istderr(),*) t, e + t=t*tstep + endif + goto 1 + end + + function cost(np,iu,d,ncl,iflag) + parameter(npmax=1000) + dimension d(npmax,npmax), iu(*), ictab(npmax) + + cost=0 + do 10 ic=1,ncl + nic=0 + do 20 n=1,np + if(iu(n).ne.ic) goto 20 + nic=nic+1 + ictab(nic)=n + 20 continue + cc=0 + do 30 ii=1,nic + i=ictab(ii) + do 30 jj=1,nic + j=ictab(jj) + 30 cc=cc+d(i,j) + 10 if(nic.gt.0) cost=cost+cc/(1+(1-iflag)*(nic-1)) + end + + function costi(np,iu,d,nn,ic,iflag) + parameter(npmax=1000) + dimension d(npmax,npmax), iu(*), ictab(npmax) + + costi=0 + nic=0 + do 20 n=1,np + if(iu(n).ne.ic) goto 20 + nic=nic+1 + ictab(nic)=n + 20 continue + cc=0 + do 30 jj=1,nic + j=ictab(jj) + 30 cc=cc+d(nn,j)+d(j,nn) + if(nic.gt.0) costi=0.5*cc/(1+(1-iflag)*(nic-1)) + end + + subroutine ranconf(np,iu,ncl,ifix) + external rand + dimension iu(*), ifix(*) + + do 10 n=1,np + iu(n)=ifix(n) + 10 if(ifix(n).eq.0) iu(n)=min(int(rand(0.0)*ncl)+1,ncl) + end + + subroutine cconf(np,iu,ncl,nch,iuold,ifix) + external rand + dimension iu(*), ifix(*) + + 1 nch=min(int(rand(0.0)*np)+1,np) + if(ifix(nch).ne.0) goto 1 + iuold=iu(nch) + iu(nch)=iuold+int(rand(0.0)*(ncl-1))+1 + if(iu(nch).gt.ncl) iu(nch)=iu(nch)-ncl + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/commandline.f b/binaries/src/disembl/Tisean_3.0.1/source_f/commandline.f new file mode 100644 index 0000000..a5d7470 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/commandline.f @@ -0,0 +1,162 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c commandline.f +c get command line options +c author T. Schreiber (1998) +c=========================================================================== + + function iopt(c,ith,ierr) +c get ith occurence of switch -c as integer + character*72 argv + character c + + iopt=0 + ifound=0 + do 10 i=1,iargc() + call getarg(i,argv) + if(argv(1:2).eq.'-'//c) then + ifound=ifound+1 + if(ifound.eq.ith) then + call argdel(i) + if(argv(3:72).ne.' ') then + iopt=i_s(argv(3:72),ierr) + else if(i+1.le.iargc()) then + call getarg(i+1,argv) + iopt=i_s(argv,ierr) + if(ierr.eq.0) call argdel(i+1) + else + ierr=1 + endif + return + endif + endif + 10 continue + ierr=1 + end + + function fopt(c,ith,ierr) +c get ith occurence of switch -c as real + character*72 argv + character c + + fopt=0 + ifound=0 + do 10 i=1,iargc() + call getarg(i,argv) + if(argv(1:2).eq.'-'//c) then + ifound=ifound+1 + if(ifound.eq.ith) then + call argdel(i) + if(argv(3:72).ne.' ') then + fopt=f_s(argv(3:72),ierr) + else if(i+1.le.iargc()) then + call getarg(i+1,argv) + fopt=f_s(argv,ierr) + if(ierr.eq.0) call argdel(i+1) + else + ierr=1 + endif + return + endif + endif + 10 continue + ierr=1 + end + + subroutine sopt(c,ith,string,ierr) +c get ith occurence of switch -c as string + character*(*) string + character c + + ifound=0 + do 10 i=1,iargc() + call getarg(i,string) + if(string(1:2).eq.'-'//c) then + ifound=ifound+1 + if(ifound.eq.ith) then + call argdel(i) + if(string(3:).ne.' ') then + string=string(3:) + ierr=0 + else if(i+1.le.iargc()) then + call getarg(i+1,string) + if(string(1:1).eq."-") then + ierr=1 + return + endif + call argdel(i+1) + ierr=0 + else + ierr=1 + endif + return + endif + endif + 10 continue + ierr=1 + end + + function lopt(c,ith) +c test if ith occurence of switch -c is present + character*72 argv + character c + + lopt=0 + ifound=0 + do 10 i=1,iargc() + call getarg(i,argv) + if(argv(1:2).eq.'-'//c) then + ifound=ifound+1 + if(ifound.eq.ith) then + lopt=1 + call argdel(i) + return + endif + endif + 10 continue + end + + function iget(inum) +c get inum'th argument as integer + character*72 argv + + iget=0 + call getarg(inum,argv) + if(argv.eq.' ') + .write(istderr(),'(a,i10)') "iget: missing integer argument",inum + iget=i_s(argv,ierr) + if(ierr.ne.0) + .write(istderr(),'(a,i10)') "iget: integer argument expected:",inum + end + + function fget(inum) +c get inum'th argument as real + character*72 argv + + fget=0 + call getarg(inum,argv) + if(argv.eq.' ') + . write(istderr(),'(a)') "fget: missing real argument",inum + fget=f_s(argv,ierr) + if(ierr.ne.0) + . write(istderr(),'(a)') "fget: real argument expected:;",inum + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/compare.f b/binaries/src/disembl/Tisean_3.0.1/source_f/compare.f new file mode 100644 index 0000000..e124a13 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/compare.f @@ -0,0 +1,72 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c compare.f +c compare two data sets +c author T. Schreiber +c=========================================================================== + + parameter(nx=1000000,mx=2) + character*72 file + dimension x(nx,mx), icol(mx) + data iverb/1/ + + call whatido("compare time series in RMS sense",iverb) + nmaxx=ican("l",nx) + nexcl=ican("x",0) + call columns(mc,mx,icol) + mcmax=mx + if(nstrings().ne.1) call usage() + call nthstring(1,file) + + nmax=nmaxx + call xreadfile(nmax,mcmax,nx,x,nexcl,icol,file,iverb) + if(file.eq."-") file="stdin" + + call rms(nmax,x(1,1),sc1,sd1) + call rms(nmax,x(1,2),sc2,sd2) + do 10 n=1,nmax + 10 x(n,1)=x(n,2)-x(n,1) + call rms(nmax,x(1,1),scd,sdd) + + write(istderr(),*) + write(istderr(),*) "col ", icol(1), ": Mean ", sc1, + . ", standard deviation ", sd1 + write(istderr(),*) "col ", icol(2), ": Mean ", sc2, + . ", standard deviation ", sd2 + write(istderr(),*) + write(istderr(),*) "mean difference ", scd + write(istderr(),*) + . "root mean squared difference ", sqrt(sdd**2+scd**2) + write(istderr(),*) "standard deviation ", sdd + end + + subroutine usage() +c usage message + + call whatineed( + . "[-l# -x# -c#[,#] -V# -h] file") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","columns to be read (1,2)") + call pall() + stop + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/d1.f b/binaries/src/disembl/Tisean_3.0.1/source_f/d1.f new file mode 100644 index 0000000..e2bdb29 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/d1.f @@ -0,0 +1,116 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c +c d1 with finite sample correction following Grassberger +c subroutine for c1 +c +c=========================================================================== + subroutine d1(nmax,mmax,nxx,y,id,m,ncmin,pr,pln,eln,nmin,kmax) + parameter(im=100,ii=100000000,nx=100000,tiny=1e-20) + dimension y(nxx,mmax),jh(0:im*im),ju(nx),d(nx),jpntr(nx), + . nlist(nx),nwork(nx) + external rand + + if(nmax.gt.nx) stop "d1: make nx larger." + mt=(m-1)/mmax+1 + ncomp=nmax-(mt-1)*id + kpr=int(exp(pr)*(ncomp-2*nmin-1))+1 + k=int(exp(pln)*(ncomp-2*nmin-1))+1 + if(k.gt.kmax) then + ncomp=real(ncomp-2*nmin-1)*real(kmax)/k+2*nmin+1 + k=kmax + endif + pln=psi(k)-log(real(ncomp-2*nmin-1)) + if(k.eq.kpr) return + write(istderr(),*) 'Mass ', exp(pln),': k=', k, ', N=', ncomp + call rms(nmax,y,sc,sd) + eps=exp(pln/m)*sd + do 10 i=1,nmax-(mt-1)*id + 10 ju(i)=i+(mt-1)*id + do 20 i=1,nmax-(mt-1)*id + iperm=min(int(rand(0.0)*nmax-(mt-1)*id)+1,nmax-(mt-1)*id) + ih=ju(i) + ju(i)=ju(iperm) + 20 ju(iperm)=ih + iu=ncmin + eln=0 + 1 call mbase(ncomp+(mt-1)*id,mmax,nxx,y,id,m,jh,jpntr,eps) + iunp=0 + do 30 nn=1,iu ! find neighbours + n=ju(nn) + call mneigh(nmax,mmax,nxx,y,n,nmax,id,m,jh,jpntr,eps, + . nlist,nfound) + nf=0 + do 40 ip=1,nfound + np=nlist(ip) + nmd=mod(abs(np-n),ncomp) + if(nmd.le.nmin.or.nmd.ge.ncomp-nmin) goto 40 ! temporal neighbours + nf=nf+1 + dis=0 + mcount=0 + do 50 i=mt-1,0,-1 + do 50 is=1,mmax + mcount=mcount+1 + if(mcount.gt.m) goto 2 + 50 dis=max(dis,abs(y(n-i*id,is)-y(np-i*id,is))) + 2 d(nf)=dis + 40 continue + if(nf.lt.k) then + iunp=iunp+1 ! mark for next sweep + ju(iunp)=n + else + e=which(nf,d,k,nwork) + eln=eln+log(max(e,tiny)) + endif + 30 continue + iu=iunp + eps=eps*sqrt(2.) + if(iunp.ne.0) goto 1 + eln=eln/(ncmin-(mt-1)*id) + end + +c digamma function +c Copyright (C) T. Schreiber (1998) + + function psi(i) + dimension p(0:20) + data p/0., + . -0.57721566490, 0.42278433509, 0.92278433509, 1.25611766843, + . 1.50611766843, 1.70611766843, 1.87278433509, 2.01564147795, + . 2.14064147795, 2.25175258906, 2.35175258906, 2.44266167997, + . 2.52599501330, 2.60291809023, 2.67434666166, 2.74101332832, + . 2.80351332832, 2.86233685773, 2.91789241329, 2.97052399224/ + + if(i.le.20) then + psi=p(i) + else + psi=log(real(i))-1/(2.*i) + endif + end + + + + + + + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/endtoend.f b/binaries/src/disembl/Tisean_3.0.1/source_f/endtoend.f new file mode 100644 index 0000000..fcfc588 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/endtoend.f @@ -0,0 +1,120 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c endtoend.f +c Determine end-to-end mismatch before making surrogate data +c author T. Schreiber (1999) +c=========================================================================== + + parameter(nx=100000,mx=20) + dimension x(nx,mx), icol(mx) + character*72 file, fout + data iverb/15/ + + call whatido("Determine end-to-end mismatch",iverb) + nmax=ican("l",nx) + nexcl=ican("x",0) + wjump=fcan("j",0.5) + mcmax=ican("m",0) + call columns(mc,mx,icol) + if(mcmax.eq.0) mcmax=max(1,mc) + isout=igetout(fout,iverb) + + call nthstring(1,file) + call xreadfile(nmax,mcmax,nx,x,nexcl,icol,file,iverb) + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_end") + call outfile(fout,iunit,iverb) + nmaxp=nmax + etotm=mcmax + 1 nmaxp=nless(nmaxp) + call jump(nmax,nmaxp,nx,x,mcmax,wjump,etot,ejump,eslip,njump) + if(etot.lt.etotm) then + etotm=etot + write(iunit,'(a,i7,a,i7,a,f5.1,a)') + . "length:", nmaxp, + . " offset: ", nexcl+njump, + . " lost: ", real(nmax-nmaxp)/real(nmax)*100, " %" + write(iunit,*) " jump: ", ejump*100, " %" + write(iunit,*) " slip: ", eslip*100, " %" + write(iunit,*) " weighted: ", etot*100, " %" + write(iunit,'()') + endif + if(etot.lt.1e-5) stop + nmaxp=nmaxp-1 + if(nmaxp.gt.2) goto 1 + end + + subroutine usage() +c usage message + + call whatineed( + . "[-j# -o outfile -l# -x# -c# -V# -h] file") + call popt("j","weight given to jump relative to slip (0.5)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("m","number of columns to be read (1)") + call popt("c","columns to be read (1)") + call pout("file_end") + call pall() + stop + end + + subroutine jump(nmax,nmaxp,nx,x,mcmax,wjump,etot,ejump,eslip, + . njump) +c loop through time ofsets to minimize jump effect + dimension x(nx,*) + + etot=mcmax + do 10 nj=0,nmax-nmaxp + xj=0 + sj=0 + do 20 m=1,mcmax + xj=xj+xjump(nmaxp,x(1+nj,m)) + 20 sj=sj+sjump(nmaxp,x(1+nj,m)) + if(wjump*xj+(1-wjump)*sj.ge.etot) goto 10 + etot=wjump*xj+(1-wjump)*sj + ejump=xj + eslip=sj + njump=nj + 10 continue + end + + function xjump(nmax,x) +c contribution of end effect to 1st derivative + dimension x(*) + + call rms(nmax,x,sc,sd) + xjump=0 + if(sd.eq.0.) return + xjump=(x(1)-x(nmax))**2/(nmax*sd**2) + end + + function sjump(nmax,x) +c contribution of end effect to 2nd derivative + dimension x(*) + + call rms(nmax,x,sc,sd) + sjump=0 + if(sd.eq.0.) return + sjump=((x(nmax)-x(nmax-1))-(x(2)-x(1)))**2 / (nmax*sd**2) + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/events.f b/binaries/src/disembl/Tisean_3.0.1/source_f/events.f new file mode 100644 index 0000000..4c4bb81 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/events.f @@ -0,0 +1,65 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c events.f +c convert inter-event intervals to event times +c author T. Schreiber (1999) +c=========================================================================== + parameter(nx=1000000) + dimension x(nx) + character*72 file, fout + data iverb/1/ + + call whatido("interval to event time conversion",iverb) + nmaxx=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + isout=igetout(fout,iverb) + + do 10 ifi=1,nstrings() + call nthstring(ifi,file) + nmax=nmaxx + call readfile(nmax,x,nexcl,jcol,file,iverb) + nmax=nmax+1 + do 20 n=nmax,2,-1 + 20 x(n)=x(n-1) + x(1)=0 + do 30 n=2,nmax + 30 x(n)=x(n)+x(n-1) + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_st") + 10 call writefile(nmax,x,fout,iverb) + end + + subroutine usage() +c usage message + + call whatineed( + . "[-o outfile -l# -x# -c# -V# -h] file(s)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_st") + call pall() + stop + end + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/gpl.txt b/binaries/src/disembl/Tisean_3.0.1/source_f/gpl.txt new file mode 100644 index 0000000..960e3b5 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/gpl.txt @@ -0,0 +1,21 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/help.f b/binaries/src/disembl/Tisean_3.0.1/source_f/help.f new file mode 100644 index 0000000..77dbdb9 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/help.f @@ -0,0 +1,80 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c help.f +c Utilities for usage message +c author T. Schreiber (1998) +c=========================================================================== + subroutine whatido(text,iverb) + character*72 progname + character*(*) text + + call getarg(0,progname) + call argdel(0) + iverb=igetv(iverb) + if(iv_io(iverb).eq.1) then + write(istderr(),'()') + write(istderr(),'(a)') + . "TISEAN 3.0.1 (C) R. Hegger, H. Kantz, T. Schreiber + .(1998-2007)" + write(istderr(),'()') + write(istderr(),'(a,a,a)') + . progname(1:index(progname," ")-1), ": ", text + endif + if(lopt("h",1).eq.1) call usage() + end + + subroutine whatineed(text) + character*72 progname + character*(*) text + + call getarg(0,progname) + write(istderr(),'()') + write(istderr(),'(a,a,x,a)') + . "Usage: ", progname(1:index(progname," ")-1), text + end + + subroutine popt(c,text) + character*(*) c,text + + write(istderr(),'(5h -,a,x,1h<,a,1h>)') c, text + end + + subroutine ptext(text) + character*(*) text + + write(istderr(),'(3x,a)') text + end + + subroutine pout(text) + character*(*) text + + write(istderr(),'(8h -o <,a,a,1h>)') + . "output file name, just -o means ", text + end + + subroutine pall() + + call popt("V","verbosity level (0 = only fatal errors)") + call popt("h","show this message") + write(istderr(),'()') + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/henon.f b/binaries/src/disembl/Tisean_3.0.1/source_f/henon.f new file mode 100644 index 0000000..0bac218 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/henon.f @@ -0,0 +1,69 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c henon.f +c iterate Henon map +c author Thomas Schreiber (1998) +c=========================================================================== + double precision xo, yo, xn, yn, a, b + character*72 fout + data a/1.4/,b/0.3/,ntrans/10000/,xo/.68587/,yo/.65876/ + data iverb/1/ + + call whatido("Henon map",iverb) + nmax=imust('l') + ntrans=ican('x',ntrans) + a=fcan('A',real(a)) + b=fcan('B',real(b)) + xo=fcan('X',real(xo)) + yo=fcan('Y',real(yo)) + isout=igetout(fout,iverb) + + if(isout.eq.1) fout="henon.dat" + call outfile(fout,iunit,iverb) + n=-ntrans + 1 n=n+1 + xn=1.-a*xo**2+b*yo + yn=xo + xo=xn + yo=yn + if(n.lt.1) goto 1 + write(iunit,*) real(xn), real(yn) + if(nmax.eq.0.or.n.lt.nmax) goto 1 + end + + subroutine usage() +c usage message + + call whatineed( + . "-l# [-A# -B# -X# -Y# -o outfile -x# -V# -h]") + call popt("l","number of points x,y (l=0: infinite)") + call popt("A","parameter a (1.4)") + call popt("B","parameter b (0.3)") + call popt("X","initial x") + call popt("Y","initial y") + call popt("x","number of transients discarded (10000)") + call pout("henon.dat") + call pall() + stop + end + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/ikeda.f b/binaries/src/disembl/Tisean_3.0.1/source_f/ikeda.f new file mode 100644 index 0000000..43ad093 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/ikeda.f @@ -0,0 +1,75 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c ikeda.f +c iterate Ikeda map +c author Thomas Schreiber (1998) +c=========================================================================== + double precision xo, yo, xn, yn, a, b, c, s, cs, ss + character*72 fout + data a/0.4/,b/6.0/,c/0.9/, + . ntrans/10000/,xo/.68587/,yo/.65876/ + data iverb/1/ + + call whatido("Ikeda map",iverb) + nmax=imust('l') + ntrans=ican('x',ntrans) + a=fcan('A',real(a)) + b=fcan('B',real(b)) + c=fcan('C',real(c)) + xo=fcan('X',real(xo)) + yo=fcan('Y',real(yo)) + isout=igetout(fout,iverb) + + if(isout.eq.1) fout="ikeda.dat" + call outfile(fout,iunit,iverb) + n=-ntrans + 1 n=n+1 + s=a-b/(1.+xo**2+yo**2) + cs=cos(s) + ss=sin(s) + xn=1.+c*(xo*cs-yo*ss) + yn=c*(xo*ss+yo*cs) + xo=xn + yo=yn + if(n.lt.1) goto 1 + write(iunit,*) real(xn), real(yn) + if(nmax.eq.0.or.n.lt.nmax) goto 1 + end + + subroutine usage() +c usage message + + call whatineed( + . "-l# [-A# -B# -C# -R# -I# -o outfile -x# -V# -h]") + call popt("l","number of points x,y (l=0: infinite)") + call popt("A","parameter a (0.4)") + call popt("B","parameter b (6.0)") + call popt("C","parameter c (0.9)") + call popt("R","initial Re(z)") + call popt("I","initial Im(z)") + call popt("x","number of transients discarded (10000)") + call pout("ikeda.dat") + call pall() + stop + end + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/intervals.f b/binaries/src/disembl/Tisean_3.0.1/source_f/intervals.f new file mode 100644 index 0000000..4674ba3 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/intervals.f @@ -0,0 +1,62 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c intervals.f +c convert event times to inter-event intervals +c author T. Schreiber (1999) +c=========================================================================== + parameter(nx=1000000) + dimension x(nx) + character*72 file, fout + data iverb/1/ + + call whatido("event time to interval conversion",iverb) + nmaxx=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + isout=igetout(fout,iverb) + + do 10 ifi=1,nstrings() + call nthstring(ifi,file) + nmax=nmaxx + call readfile(nmax,x,nexcl,jcol,file,iverb) + nmax=nmax-1 + do 20 n=1,nmax + 20 x(n)=x(n+1)-x(n) + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_ss") + 10 call writefile(nmax,x,fout,iverb) + end + + subroutine usage() +c usage message + + call whatineed( + . "[-o outfile -l# -x# -c# -V# -h] file(s)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_ss") + call pall() + stop + end + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/istdio_temp.f b/binaries/src/disembl/Tisean_3.0.1/source_f/istdio_temp.f new file mode 100644 index 0000000..fd11d44 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/istdio_temp.f @@ -0,0 +1,44 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c istdio_temp.f +c standard input-output unit assignments for TISEAN f-sources +c + function istderr() + istderr=ERRUNIT + end + + function istdin() + istdin=5 + end + + function istdout() + istdout=6 + end + + function ifilein() + ifilein=10 + end + + function ifileout() + ifileout=11 + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/lazy.f b/binaries/src/disembl/Tisean_3.0.1/source_f/lazy.f new file mode 100644 index 0000000..1ae4ba4 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/lazy.f @@ -0,0 +1,109 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c lazy.f +c simple nonlinear noise reduction +c see H. Kantz, T. Schreiber, Nonlinear Time Series Analysis, Cambridge +c University Press (1997,2004) +c author T. Schreiber (1998) +c=========================================================================== + parameter(nx=1000000) + dimension x(nx), x0(nx), xc(nx) + character*72 file, fout + data eps/0./, frac/0./, imax/1/ + data iverb/1/ + + call whatido("simple nonlinear noise reduction",iverb) + m=imust("m") + eps=fcan("r",eps) + frac=fcan("v",frac) + imax=ican("i",imax) + nmax=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + isout=igetout(fout,iverb) + if(eps.eq.0.and.frac.eq.0.) call usage() + + call nthstring(1,file) + call readfile(nmax,x,nexcl,jcol,file,iverb) + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_l") + call rms(nmax,x,sc,sd) + if(frac.gt.0) eps=sd*frac + do 10 n=1,nmax + 10 x0(n)=x(n) + do 20 it=1,imax + call nrlazy(nmax,x,xc,m,eps) + if(fout.ne." ".or.isout.eq.1.or.it.eq.imax) then + if(isout.eq.1) call suffix(fout,"c") + call outfile(fout,iunit,iverb) + do 30 n=1,nmax + 30 write(iunit,*) xc(n), x0(n)-xc(n) + if(iunit.ne.istdout()) close(iunit) + if(iv_io(iverb).eq.1) call writereport(nmax,fout) + endif + eps=0 + do 40 n=1,nmax + eps=eps+(xc(n)-x(n))**2 + 40 x(n)=xc(n) + eps=sqrt(eps/nmax) + if(eps.eq.0.) then + if(iv_io(iverb).eq.1) write(istderr(),*) + . 'Zero correction, finished' + stop + endif + 20 if(iv_io(iverb).eq.1) write(istderr(),*) + . 'New diameter of neighbourhoods is ', eps + end + + subroutine usage() +c usage message + + call whatineed( + . "-m# [-r# | -v#] [-i# -o outfile -l# -x# -c# -V# -h] file") + call ptext("either -r or -v must be present") + call popt("m","embedding dimension") + call popt("r","absolut radius of neighbourhoods") + call popt("v","same as fraction of standard deviation") + call popt("i","number of iterations (1)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_lc, file_lcc (etc.)") + call pall() + stop + end + + subroutine nrlazy(nmax,y,yc,m,eps) + parameter(im=100,ii=100000000,nx=1000000) + dimension y(nmax),yc(nmax),jh(0:im*im),jpntr(nx),nlist(nx) + + if(nmax.gt.nx) stop "nrlazy: make nx larger." + call base(nmax,y,1,m,jh,jpntr,eps) + do 10 n=1,nmax + 10 yc(n)=y(n) + do 20 n=m,nmax + call neigh(nmax,y,y,n,nmax,1,m,jh,jpntr,eps,nlist,nfound) + av=0 + do 30 nn=1,nfound + 30 av=av+y(nlist(nn)-(m-1)/2) ! average middle coordinate + 20 yc(n-(m-1)/2)=av/nfound + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/lorenz.f b/binaries/src/disembl/Tisean_3.0.1/source_f/lorenz.f new file mode 100644 index 0000000..302717d --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/lorenz.f @@ -0,0 +1,311 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c lorenz.f +c integrates the Lorenz system with Runge Kutta fourth order +c author: H. Kantz (2007) based on earlier versions +c with optional noise +c=========================================================================== +c + + real*8 x(3),u(3,3),sliap(3),bb,ss,rr,r1,r2,dh,s + character*72 fout + data iverb/1/ + + iverb=ican('V',iverb) + call whatido("integration of the Lorenz system",iverb) + irun=imust('l') + itrans=ican('x',100) + rr=fcan('R',28.0) + ss=fcan('S',10.0) + bb=fcan('B',2.666666667) + isamp=ican('f',100) + sn=fcan('r',0.) +c ilyap=lopt('L',1) + + isout=igetout(fout,iverb) + + if(isout.eq.1) fout="lorenz.dat" + call outfile(fout,iunit,iverb) + +cc intermittency parameters +c ss=10.d0 +c rr=166.11d0 +c bb=8.d0/3.d0 + + iseed1=6456423 + iseed2=7243431 + + xav=0. + xsq=0. + rsq=0. + +c step width of Runge Kutta integration dh: + dh=.0005d0 +c time intervals between re-orthogonalization of tangent space +c vectors: 0.01 units of time. + ireno=.01d0/dh +c length of transient in iteration steps: + itrans=real(itrans)/dh + totaltime=real(irun)/real(isamp) + istep=1.d0/dh/isamp + + if (iverb.eq.1) + . write(istderr(),*)'Lorenz trajectory covering',totaltime, + . ' time units' + +c x(1)=sqrt(s*(r+1.d0))+2. +c x(2)=x(1)-1.d0 +c x(3)=r + + x(1)=5. + x(2)=-10. + x(3)=3. + + do 1 i=1,3 + sliap(i)=0.d0 + do j=1,3 + u(i,j)=0.d0 + enddo + u(i,i)=1.d0 +1 continue + + do 10 i2=1,itrans + + call RUKU(3,x,u,dh,bb,ss,rr) + + if (mod(i2,ireno).eq.0) then + call norm(u,1,s) + do i=2,3 + do j=1,i-1 + call proj(u,i,j) + enddo + call NORM(u,i,s) + enddo + endif + +10 continue + + write(iunit,101)x(1),x(2),x(3) + + 100 continue + do 20 i2=1,irun*istep +c add noise + if (sn.gt.0.0) then + call gauss(r1,r2,iseed1,iseed2) + x(1)=x(1)+r1*sn + x(2)=x(2)+r2*sn + call gauss(r1,r2,iseed1,iseed2) + x(3)=x(3)+r1*sn + xav=xav+x(1) + xsq=xsq+x(1)**2 + rsq=rsq+r1*r1 + endif + call RUKU(3,x,u,dh,bb,ss,rr) + if (mod(i2,istep).eq.0) write(iunit,101)x(1),x(2),x(3) + if (mod(i2,ireno).eq.0) then +c Gram Schmidt Orthonormierung + call norm(u,1,s) + sliap(1)=sliap(1)+log(s) + do i=2,3 + do j=1,i-1 + call proj(u,i,j) + enddo + call NORM(u,i,s) + sliap(i)=sliap(i)+log(s) + enddo + endif + + 20 continue + + if (sn.gt.0.0) then + xav=xav/irun/istep + xsq=xsq/irun/istep + rsq=rsq/irun/istep + rlevel=sqrt(rsq)/sqrt(xsq-xav*xav)*100. + if (iverb.eq.1) + . print*,'noise level in percent of x-coordinate',rlevel + endif + if (iverb.eq.1) then + write(istderr(),*) + write(istderr(),*)'Lyapunov exponents [1/unit time]' + do i=1,3 + write(istderr(),*)real(sliap(i)/totaltime) + enddo + endif + + 101 format(2x,3f10.3) + + stop + end + + subroutine FORCE(x,ff,dh,bb,ss,rr) + real*8 x(3),ff(3),dh,bb,ss,rr + + ff(1)=dh*ss*(x(2)-x(1)) + ff(2)=dh*(x(1)*(-x(3)+rr)-x(2)) + ff(3)=dh*(x(1)*x(2)-bb*x(3)) + + return + end + + subroutine LFORCE(x,u,fl,dh,bb,ss,rr) + real*8 x(3),u(3,3),dh,fl(3,3),bb,ss,rr + + do j=1,3 + fl(j,1)=dh*ss*(u(j,2)-u(j,1)) + fl(j,2)=dh*(u(j,1)*(rr-x(3))-x(1)*u(j,3)-u(j,2)) + fl(j,3)=dh*(u(j,1)*x(2)+x(1)*u(j,2)-bb*u(j,3)) + enddo + return + end + + subroutine RUKU(n,x,u,dh,bb,ss,rr) +c 4th-order Runge Kutta +c initial point x +c final point y +c stepsize dh +c add subroutine force + + implicit real*8 (a-h,o-z) + real*8 x(3),ff1(3),ff2(3),ff3(3),ff4(3),dummy(3) + real*8 u(3,3),fl1(3,3),fl2(3,3),fl3(3,3),fl4(3,3) + real*8 dl(3,3) + + call force(x,ff1,dh,bb,ss,rr) + call LFORCE(x,u,fl1,dh,bb,ss,rr) + + do i=1,n + dummy(i)=ff1(i)*.5d0+x(i) + do j=1,3 + dl(i,j)=fl1(i,j)*.5d0+u(i,j) + enddo + enddo + + call force(dummy,ff2,dh,bb,ss,rr) + call LFORCE(dummy,dl,fl2,dh,bb,ss,rr) + + do i=1,n + dummy(i)=ff2(i)*.5d0+x(i) + do j=1,3 + dl(i,j)=fl2(i,j)*.5d0+u(i,j) + enddo + enddo + + call force(dummy,ff3,dh,bb,ss,rr) + call LFORCE(dummy,dl,fl3,dh,bb,ss,rr) + + do i=1,n + dummy(i)=ff3(i)+x(i) + do j=1,3 + dl(i,j)=fl3(i,j)+u(i,j) + enddo + enddo + + call force(dummy,ff4,dh,bb,ss,rr) + call LFORCE(dummy,dl,fl4,dh,bb,ss,rr) + + do i=1,n + x(i)=x(i)+ff1(i)/6.d0+ff2(i)/3.d0+ff3(i)/3.d0+ff4(i)/6.d0 + do j=1,3 + u(i,j)=u(i,j)+fl1(i,j)/6.d0+fl2(i,j)/3.d0+fl3(i,j)/3.d0 + + +fl4(i,j)/6.d0 + enddo + enddo + + return + end + + subroutine NORM(u,i,s) + real*8 u(3,3),s + + s=0.d0 + do 10 j=1,3 +10 s=s+u(i,j)**2 + s=sqrt(s) + si=1.d0/s + do 20 j=1,3 +20 u(i,j)=u(i,j)*si + return + end + + subroutine PROJ(u,i,j) + real*8 u(3,3),s + s=0.d0 + do 10 k=1,3 +10 s=s+u(i,k)*u(j,k) + do 20 k=1,3 +20 u(i,k)=u(i,k)-s*u(j,k) + return + end + +c>------------------------------------------------------- + subroutine gauss(r1,r2,iseed1,iseed2) + + real*8 r1,r2,p,phi,r + pii=8.d0*atan(1.d0) + + call RANDOM1(p,iseed1) + call RANDOM1(phi,iseed2) + + phi=phi*pii + r=sqrt(-log(1.d0-p)*2.d0) + + r1=r*sin(phi) + r2=r*cos(phi) + return + end +c>------------------------------------------------------- + subroutine RANDOM1(r,iseed) +c +c random number generator of Park & Miller +c random numbers in [0,1] !!! + real*8 r + integer*8 ia,im,ix + ia=7**5 + im=2147483647 + ix=iseed + ix=mod(ia*ix,im) + r=dfloat(ix)/dfloat(im) + iseed=ix + return + end +c>------------------------------------------------------------------ + subroutine usage() +c usage message + + call whatineed( + . "-l# [-f# -r# -R# -S# -B# -o outfile -x# -V# -h]") + call popt("l","length of trajectory x,y,z") + call popt("f","sample points per unit time [100]") + call popt("r","absolute noise amplitute [0]") + call popt("R","parameter r [28]") + call popt("S","parameter sigma [10]") + call popt("B","parameter b [8/3]") + call popt("x","transient discarded [100 units of time]") +c call popt("L","if present: compute Lyapunov exponents") + call pout("lorenz.dat") + call pall() + stop + end + + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/neigh.f b/binaries/src/disembl/Tisean_3.0.1/source_f/neigh.f new file mode 100644 index 0000000..f13e83a --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/neigh.f @@ -0,0 +1,182 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c utilities for neighbour search +c see H. Kantz, T. Schreiber, Nonlinear Time Series Analysis, Cambridge +c University Press (1997) +c author T. Schreiber (1999) +c last modified H. Kantz Feb.2007 +c=========================================================================== + subroutine base(nmax,y,id,m,jh,jpntr,eps) + parameter(im=100,ii=100000000) + dimension y(nmax),jh(0:im*im),jpntr(nmax) + + do 10 i=0,im*im + 10 jh(i)=0 + do 20 n=(m-1)*id+1,nmax ! make histogram + i=mod(int(y(n)/eps)+ii,im) + if(m.gt.1) i=im*i+mod(int(y(n-(m-1)*id)/eps)+ii,im) + 20 jh(i)=jh(i)+1 + do 30 i=1,im*im ! accumulate it + 30 jh(i)=jh(i)+jh(i-1) + do 40 n=(m-1)*id+1,nmax ! fill list of pointers + + i=mod(int(y(n)/eps)+ii,im) + if(m.gt.1) i=im*i+mod(int(y(n-(m-1)*id)/eps)+ii,im) + jpntr(jh(i))=n + 40 jh(i)=jh(i)-1 + end + + subroutine neigh(nmax,y,x,n,nlast,id,m,jh,jpntr,eps,nlist,nfound) + parameter(im=100,ii=100000000) + dimension y(nmax),x(nmax),jh(0:im*im),jpntr(nmax),nlist(nmax) + + nfound=0 + kloop=1 + if(m.eq.1) kloop=0 + jj=int(y(n)/eps) + + kk=int(y(n-(m-1)*id)/eps) + do 10 j=jj-1,jj+1 ! scan neighbouring boxes + do 20 k=kk-kloop,kk+kloop + jk=mod(j+ii,im) + if(m.gt.1) jk=im*jk+mod(k+ii,im) + do 30 ip=jh(jk+1),jh(jk)+1,-1 ! this is in time order + np=jpntr(ip) + if(np.gt.nlast) goto 20 + do 40 i=0,m-1 + 40 if(abs(y(n-i*id)-x(np-i*id)).ge.eps) goto 30 + nfound=nfound+1 + nlist(nfound)=np ! make list of neighbours + 30 continue + 20 continue + 10 continue + end + +c versions for multivariate series +c author T. Schreiber (1999) + + subroutine mbase(nmax,mmax,nxx,y,id,m,jh,jpntr,eps) + parameter(im=100,ii=100000000) + dimension y(nxx,mmax),jh(0:im*im),jpntr(nmax) + + if(mmax.eq.1) then + call base(nmax,y,id,m,jh,jpntr,eps) + return + endif + mt=(m-1)/mmax+1 + do 10 i=0,im*im + 10 jh(i)=0 + do 20 n=(mt-1)*id+1,nmax ! make histogram + i=im*mod(int(y(n,1)/eps)+ii,im)+mod(int(y(n,mmax)/eps)+ii,im) + 20 jh(i)=jh(i)+1 + do 30 i=1,im*im ! accumulate it + 30 jh(i)=jh(i)+jh(i-1) + do 40 n=(mt-1)*id+1,nmax ! fill list of pointers + i=im*mod(int(y(n,1)/eps)+ii,im)+mod(int(y(n,mmax)/eps)+ii,im) + jpntr(jh(i))=n + 40 jh(i)=jh(i)-1 + end + + subroutine mneigh(nmax,mmax,nxx,y,n,nlast,id,m,jh,jpntr,eps, + . nlist,nfound) + parameter(im=100,ii=100000000) + dimension y(nxx,mmax),jh(0:im*im),jpntr(nmax),nlist(nmax) + + if(mmax.eq.1) then + call neigh(nmax,y,y,n,nlast,id,m,jh,jpntr,eps,nlist,nfound) + return + endif + mt=(m-1)/mmax+1 + nfound=0 + jj=int(y(n,1)/eps) + kk=int(y(n,mmax)/eps) + do 10 j=jj-1,jj+1 ! scan neighbouring boxes + do 20 k=kk-1,kk+1 + jk=im*mod(j+ii,im)+mod(k+ii,im) + do 30 ip=jh(jk+1),jh(jk)+1,-1 ! this is in time order + np=jpntr(ip) + if(np.gt.nlast) goto 20 + mcount=0 + do 40 i=mt-1,0,-1 + do 40 is=1,mmax + mcount=mcount+1 + if(mcount.gt.m) goto 1 + 40 if(abs(y(n-i*id,is)-y(np-i*id,is)).ge.eps) goto 30 + 1 nfound=nfound+1 + nlist(nfound)=np ! make list of neighbours + 30 continue + 20 continue + 10 continue + end +c>--------------------------------------------------------------------- +c modified version for multivariate series +c author H. Kantz (2004) + + subroutine mneigh2(nmax,mdim,y,nx,vx,jh,jpntr,eps, + . nlist,nfound) +c +c search neighbours for vx among the set of all y's +c multivariate: mmax: spatial dimension +c no additional delay! + parameter(im=100,ii=100000000) + dimension y(nx,mdim),jh(0:im*im),jpntr(nmax),nlist(nmax) + dimension vx(mdim) + + nfound=0 + jj=int(vx(1)/eps) + kk=int(vx(mdim)/eps) + do 10 j=jj-1,jj+1 ! scan neighbouring boxes + do 20 k=kk-1,kk+1 + jk=im*mod(j+ii,im)+mod(k+ii,im) + do 30 ip=jh(jk+1),jh(jk)+1,-1 ! this is in time order + np=jpntr(ip) +c if(np.gt.nlast) goto 20 + mcount=0 + do 40 is=1,mdim + 40 if(abs(vx(is)-y(np,is)).ge.eps) goto 30 + 1 nfound=nfound+1 + nlist(nfound)=np ! make list of neighbours + 30 continue + 20 continue + 10 continue + end + + subroutine mbase2(nmax,mmax,nxx,y,jh,jpntr,eps) + parameter(im=100,ii=100000000) + dimension y(nxx,mmax),jh(0:im*im),jpntr(nmax) + + if(mmax.eq.1) then + call base(nmax,y,id,m,jh,jpntr,eps) + return + endif + do 10 i=0,im*im + 10 jh(i)=0 + do 20 n=1,nmax ! make histogram + i=im*mod(int(y(n,1)/eps)+ii,im)+mod(int(y(n,mmax)/eps)+ii,im) + 20 jh(i)=jh(i)+1 + do 30 i=1,im*im ! accumulate it + 30 jh(i)=jh(i)+jh(i-1) + do 40 n=(mmax-1)*id+1,nmax ! fill list of pointers + i=im*mod(int(y(n,1)/eps)+ii,im)+mod(int(y(n,mmax)/eps)+ii,im) + jpntr(jh(i))=n + 40 jh(i)=jh(i)-1 + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/nmore.f b/binaries/src/disembl/Tisean_3.0.1/source_f/nmore.f new file mode 100644 index 0000000..26e7037 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/nmore.f @@ -0,0 +1,58 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c utilities for TISEAN f-sources +c + function nmore(n) +c find smallest factorisable number .ge.n + + nmore=n + 1 if(isfact(nmore).eq.1) return + nmore=nmore+1 + goto 1 + end + + function nless(n) +c find largest factorisable number .le.n + + nless=n + 1 if(isfact(nless).eq.1) return + nless=nless-1 + goto 1 + end + + function isfact(n) +c determine if n is factorisable using the first nprimes primes + parameter(nprimes=3) + dimension iprime(nprimes) + data iprime/2,3,5/ + + isfact=1 + ncur=n + 1 if(ncur.eq.1) return + do 10 i=1,nprimes + if(mod(ncur,iprime(i)).eq.0) then + ncur=ncur/iprime(i) + goto 1 + endif + 10 continue + isfact=0 + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/normal.f b/binaries/src/disembl/Tisean_3.0.1/source_f/normal.f new file mode 100644 index 0000000..53a9a0f --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/normal.f @@ -0,0 +1,70 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c utilities for normalisation of time series +c author T. Schreiber (1998) +c=========================================================================== + subroutine rms(nmax,x,sc,sd) +c return mean sc and rms amplitude sd + dimension x(nmax) + + sc=0. + do 10 n=1,nmax + 10 sc=sc+x(n) + sc=sc/nmax + sd=0. + do 20 n=1,nmax + 20 sd=sd+(x(n)-sc)**2 + sd=sqrt(sd/nmax) + end + + subroutine normal(nmax,x,sc,sd) +c subtract mean, return mean sc and rms amplitude sd + dimension x(nmax) + + call rms(nmax,x,sc,sd) + do 10 n=1,nmax + 10 x(n)=x(n)-sc + end + + subroutine normal1(nmax,x,sc,sd) +c subtract mean, rescale to unit variance, +c return mean sc and rms amplitude sd + dimension x(nmax) + + call rms(nmax,x,sc,sd) + if(sd.eq.0.) stop + . "normal1: zero variance, cannot normalise" + do 10 n=1,nmax + 10 x(n)=(x(n)-sc)/sd + end + + subroutine minmax(nmax,x,xmin,xmax) +c obtain smallest and largest value in x + dimension x(nmax) + + xmin=x(1) + xmax=x(1) + do 10 n=2,nmax + xmin=min(x(n),xmin) + 10 xmax=max(x(n),xmax) + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/notch.f b/binaries/src/disembl/Tisean_3.0.1/source_f/notch.f new file mode 100644 index 0000000..52265e0 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/notch.f @@ -0,0 +1,86 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c notch filter in the time domain +c author T. Schreiber +c=========================================================================== + + parameter(nx=1000000) + dimension x(nx), y(nx) + character*72 file, fout + data h/1./, w/0.01/, pi/3.1415926/ + data iverb/1/ + + call whatido("notch filter",iverb) + f=fmust("X") + h=fcan("f",h) + w=fcan("w",w) + fw=tan(pi*f/h) + nmaxx=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + isout=igetout(fout,iverb) + + do 10 ifi=1,nstrings() + call nthstring(ifi,file) + nmax=nmaxx + call readfile(nmax,x,nexcl,jcol,file,iverb) + if(file.eq."-") file="stdin" + d=fnotch(nmax,x,y,fw,w) + if(isout.eq.1) call addsuff(fout,file,"_notch") + 10 call writefile(nmax,y,fout,iverb) + end + + function fnotch(nmax,x,y,fw,w) + dimension x(nmax), y(nmax) + + a=(1+w*fw)**2+fw**2 + c0= (1+fw**2)/a + c1=-2*(1-fw**2)/a + c2=c0 + d1= 2*(1-w**2*fw**2-fw**2)/a + d2= -((1-w*fw)**2+fw**2)/a + + y(1)=c0*x(1) + y(2)=c0*x(2)+c1*x(1)+d1*y(1) + do 10 n=3,nmax + 10 y(n)=c0*x(n)+c1*x(n-1)+c2*x(n-2)+d1*y(n-1)+d2*y(n-2) + fnotch=0 + do 20 n=1,nmax + 20 fnotch=fnotch+(x(n)-y(n))**2 + fnotch=sqrt(fnotch/nmax) + end + + subroutine usage() +c usage message + + call whatineed( + . "-X# [-f# -w# -o outfile -l# -x# -c# -V# -h] file(s)") + call popt("X","frequency to be cancelled") + call popt("f","sampling rate of data (1)") + call popt("w","width of filter (f/100)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_notch") + call pall() + stop + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/pc.f b/binaries/src/disembl/Tisean_3.0.1/source_f/pc.f new file mode 100644 index 0000000..d57f98c --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/pc.f @@ -0,0 +1,96 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c embed using principal components +C author Thomas Schreiber (1998) +c=========================================================================== + parameter(nx=1000000, me=500) + dimension x(nx), c(me,me), d(me), xc(me), z(me,me) + character*72 file, fout + data id/1/, isvd/2/ + data iverb/1/ + + call whatido("embed using principal components",iverb) + m=imust("m") + if(m.gt.me) stop "svd: make me larger." + id=ican("d",id) + isvd=min(ican("q",isvd),m) + nmax=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + isout=igetout(fout,iverb) + + call nthstring(1,file) + call readfile(nmax,x,nexcl,jcol,file,iverb) + call normal(nmax,x,sc,sd) + call svd_vectors(nmax,m,id,x,c,z,d) + if(iv_io(iverb).eq.1) write(istderr(),*) + . "#, fraction of variance, accumulative fraction" + ctot=0. + do 10 i=1,m + 10 ctot=ctot+d(m+1-i) + cacc=0. + do 20 i=1,m + cacc=cacc+d(m+1-i) + 20 if(iv_io(iverb).eq.1) + . write(istderr(),*) i, d(m+1-i)/ctot, cacc/ctot + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_pc") + call outfile(fout,iunit,iverb) + do 30 n=(m-1)*id+1,nmax + do 40 i=1,isvd + s=0 + do 50 j=1,m + 50 s=s+z(j,m+1-i)*x(n-(j-1)*id) + 40 xc(i)=s + 30 write(iunit,*) (xc(i),i=1,isvd) + end + + subroutine usage() +c usage message + + call whatineed( + . "-m# [-d# -q# -o outfile -l# -x# -c# -V# -h] file") + call popt("m","initial embedding dimension") + call popt("d","delay for initial embedding (1)") + call popt("q","number of principal components (2)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_pc") + call pall() + stop + end + + subroutine svd_vectors(nmax,m,id,x,c,z,d) + parameter(me=500) + dimension x(nmax), c(me,*), d(m), w1(me), w2(me), z(me,*) + + if(m.gt.me) stop "svd_vectors: make me larger." + do 10 i=1,m + do 10 j=i,m + s=0. + do 20 n=(m-1)*id+1,nmax + 20 s=s+x(n-(i-1)*id)*x(n-(j-1)*id) + c(i,j)=s/(nmax-(m-1)*id) + 10 c(j,i)=c(i,j) + call rs(me,m,c,d,1,z,w1,w2,ierr) + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/predict.f b/binaries/src/disembl/Tisean_3.0.1/source_f/predict.f new file mode 100644 index 0000000..0e8d161 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/predict.f @@ -0,0 +1,104 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c simple nonlinear prediction, fast neighbour search +c see H. Kantz, T. Schreiber, Nonlinear Time Series Analysis, Cambridge +c University Press (1997,2004) +c author T. Schreiber (1998) +c=========================================================================== + parameter(nx=1000000) + dimension x(nx), y(nx) + character*72 file, fout + data eps/0./, frac/0./, ifc/1/ + data iverb/1/ + + call whatido("prediction with locally constant fits",iverb) + id=imust("d") + m=imust("m") + eps=fcan("r",eps) + frac=fcan("v",frac) + ifc=ican("s",ifc) + nmaxx=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + isout=igetout(fout,iverb) + if(eps.eq.0.and.frac.eq.0.) call usage() + + do 10 ifi=1,nstrings() + call nthstring(ifi,file) + nmax=nmaxx + call readfile(nmax,x,nexcl,jcol,file,iverb) + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_pred") + call rms(nmax,x,sc,sd) + if(frac.gt.0) eps=sd*frac + iun=istdout() + if(fout.eq." ") iun=istderr() + write(iun,*) "err: ", fcerror(nmax,x,y,m,id,ifc,eps), + . " "//file(1:index(file," ")-1) + 10 call writefile(nmax,y,fout,iverb) + end + + subroutine usage() +c usage message + + call whatineed( + . "-d# -m# [-r# | -v#]"// + . " [-s# -o outfile -l# -x# -c# -V# -h] file(s)") + call ptext("either -r or -v must be present") + call popt("d","delay") + call popt("m","embedding dimension") + call popt("r","absolute radius of neighbourhoods") + call popt("v","same as fraction of standard deviation") + call popt("s","time steps ahead forecast (one step)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_pred") + call pall() + stop + end + + function fcerror(nmax,y,yp,m,id,ifc,eps) + parameter(im=100,ii=100000000,nx=1000000) + dimension y(nmax),yp(nx),jh(0:im*im),jpntr(nx),nlist(nx) + + if(nmax.gt.nx) stop "fcerror: make nx larger." + call base(nmax-ifc,y,id,m,jh,jpntr,eps) + fcerror=0 + + call rms(nmax,y,sx,sd) + do 10 n=1,(m-1)*id+ifc + 10 yp(n)=sx + do 20 n=(m-1)*id+1,nmax-ifc + call neigh(nmax,y,y,n,nmax,id,m,jh,jpntr,eps,nlist,nfound) + av=0 + do 30 nn=1,nfound + 30 if(nlist(nn).ne.n) av=av+y(nlist(nn)+ifc) + if(nfound.gt.1) then + yp(n+ifc)=av/(nfound-1) + else + yp(n+ifc)=sx + endif + 20 fcerror=fcerror+(y(n+ifc)-yp(n+ifc))**2 + fcerror=sqrt(fcerror/(nmax-ifc-(m-1)*id)) + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/project.f b/binaries/src/disembl/Tisean_3.0.1/source_f/project.f new file mode 100644 index 0000000..4f1c0f4 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/project.f @@ -0,0 +1,172 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c nonlinear noise reduction +c see H. Kantz, T. Schreiber, Nonlinear Time Series Analysis, Cambridge +c University Press (1997,2004) +c authors T. Schreiber, H. Kantz, R. Hegger (1998) based on earlier versions +c=========================================================================== + parameter(nx=100000) + dimension x(nx), x0(nx), xc(nx) + character*72 file, fout + data imax/1/ + data iverb/1/ + + call whatido("nonlinear noise reduction (see also: noise)",iverb) + m=imust("m") + nq=m-imust("q") + eps=fmust("r",eps) + kmin=imust("k") + imax=ican("i",imax) + nmax=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + isout=igetout(fout,iverb) + + call nthstring(1,file) + call readfile(nmax,x,nexcl,jcol,file,iverb) + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_") + + do 10 n=1,nmax + 10 x0(n)=x(n) + do 20 it=1,imax + call clean(nmax,x,xc,m,kmin,nq,eps,iverb) + if(fout.ne." ".or.isout.eq.1.or.it.eq.imax) then + if(isout.eq.1) call suffix(fout,"c") + call outfile(fout,iunit,iverb) + do 30 n=1,nmax + 30 write(iunit,*) xc(n), x0(n)-xc(n) + if(iunit.ne.istdout()) close(iunit) + if(iv_io(iverb).eq.1) call writereport(nmax,fout) + endif + eps=0 + do 40 n=1,nmax + eps=eps+(xc(n)-x(n))**2 + 40 x(n)=xc(n) + eps=sqrt(eps/nmax) + 20 if(iv_io(iverb).eq.1) + . write(istderr(),*) 'New diameter of neighbourhoods is ', eps + end + + subroutine usage() +c usage message + + call whatineed( + . "-m# -q# -r# -k# [-i# -o outfile -l# -x# -c# -V# -h] file") + call popt("m","embedding dimension") + call popt("q","dimension of manifold") + call popt("r","radius of neighbourhoods") + call popt("k","minimal number of neighbours") + call popt("i","number of iterations (1)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_c, file_cc (etc.)") + call pall() + call ptext("Verbosity levels (add what you want):") + call ptext(" 1 = input/output" ) + call ptext(" 2 = state of neighbour search") + write(istderr(),'()') + stop + end + + subroutine clean(nmax,y,yc,m,kmin,nq,d,iverb) + parameter(im=100,ii=100000000,nx=100000,mm=15,small=0.0001) + dimension y(nmax),yc(nmax),r(mm),ju(nx),c(mm,mm),cm(mm), + . jh(0:im*im),jpntr(nx),nlist(nx), zcm(mm,nx) + + if(nmax.gt.nx.or.m.gt.mm) stop "clean: make mm/nx larger." + sr=2*small+m-2 ! ${\rm tr}(1/r)=1$ + do 10 i=1,m + r(i)=sr + 10 if(i.eq.m.or.i.eq.1) r(i)=sr/small + do 20 i=1,nmax + 20 yc(i)=y(i) + do 30 istep=1,2 + eps=d + iu=nmax-m+1 + do 40 i=1,iu + 40 ju(i)=i+m-1 + 1 call base(nmax,y,1,m,jh,jpntr,eps) + iunp=0 + do 50 nn=1,iu ! find neighbours + n=ju(nn) + call neigh(nmax,y,y,n,nmax,1,m,jh,jpntr,eps,nlist,nfound) + if(nfound.lt.kmin) then ! not enough neighbours found + iunp=iunp+1 ! mark for next sweep + ju(iunp)=n + else ! fine: enough neighbours + do 90 i=1,m ! centre of mass vector + s=0 + do 100 np=1,nfound + 100 s=s+y(nlist(np)-m+i) + 90 cm(i)=s/nfound + if(istep.eq.1) then ! just store centre of mass + do 110 i=1,m + 110 zcm(i,n)=cm(i) + else + do 120 i=1,m ! corrected centre of mass vector + s=0 + do 130 np=1,nfound + 130 s=s+zcm(i,nlist(np)) + 120 cm(i)=2*cm(i)-s/nfound + do 140 i=1,m ! compute covariance matrix + do 140 j=i,m + s=0 + do 150 np=1,nfound + jm=nlist(np)-m + 150 s=s+(y(jm+i)-cm(i))*(y(jm+j)-cm(j)) + c(i,j)=r(i)*r(j)*s/nfound + 140 c(j,i)=c(i,j) + call eigen(c,m) ! find eigenvectors (decreasing) + do 160 i=1,m + s=0 + do 170 iq=m-nq+1,m + do 170 j=1,m + 170 s=s+(y(n-m+j)-cm(j))*c(i,iq)*c(j,iq)*r(j) + 160 yc(n-m+i)=yc(n-m+i)-s/r(i)/r(i) + endif + endif + 50 continue + iu=iunp + if(iv_uncorr(iverb).eq.1) + . write(istderr(),*) "With ", eps, iunp, " uncorrected" + eps=eps*sqrt(2.) + 30 if(iunp.ne.0) goto 1 + end + +c driver for diagonalisation routines +c see H. Kantz, T. Schreiber, Nonlinear Time Series Analysis, Cambridge +c University Press (1997) +c Copyright (C) T. Schreiber (1997) + + subroutine eigen(c,kk) + parameter(md=15) + dimension c(md,md),d(md),w1(md),w2(md),z(md,md) + if(kk.gt.md) stop "eigen: make md larger." + + call rs(md,kk,c,d,1,z,w1,w2,ierr) + do 10 i=1,kk + do 10 j=1,kk + 10 c(i,j)=z(i,kk+1-j) + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/Makefile.in b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/Makefile.in new file mode 100644 index 0000000..7e69a68 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/Makefile.in @@ -0,0 +1,53 @@ +SHELL = /bin/sh + +prefix = @prefix@ +exec_prefix = @exec_prefix@ +BINDIR = ${exec_prefix}/@bindir@ + +FC = @FC@ +FFLAGS = @FFLAGS@ +INSTALL = @INSTALL@ +LDFLAGS = @LDFLAGS@ + +LOADLIBES = ../libtsa.a ../libsla.a + +SRC = randomize.f cost/$(COST).o cool/$(COOL).o perm/$(PERM).o +TRG = randomize_$(COST)_$(COOL)_$(PERM) + +all install clean missing uninstall: + -$(MAKE) COST=auto COOL=exp PERM=random $@-one + -$(MAKE) COST=autop COOL=exp PERM=random $@-one + -$(MAKE) COST=spikeauto COOL=exp PERM=random $@-one + -$(MAKE) COST=spikespec COOL=exp PERM=event $@-one + -$(MAKE) COST=uneven COOL=exp PERM=random $@-one +# add more similar lines for each module you have written +# for example if you created cost/mycost.f +# -$(MAKE) COST=mycost COOL=exp PERM=random $@-one + +install-one: $(TRG) + -$(INSTALL) $(TRG) $(BINDIR) + +missing-one: + -@$(TRG) -h 2>&1 | cat >> ../../install.log + -@test -z "`$(TRG) -h 2>&1 | grep Usage`" \ + && echo $(TRG) "(Wuppertal Fortran)" >> ../../missing.log; : + +uninstall-one: + -@rm -f $(BINDIR)/$(TRG) + +clean-one: + @rm -f $(TRG) + +all-one: $(TRG) + +$(TRG): $(SRC) + -$(FC) $(FFLAGS) $(SRC) -o $(TRG) $(LOADLIBES) $(LDFLAGS) + +cost/$(COST).o: cost/$(COST).f + $(FC) $(FFLAGS) -c cost/$(COST).f -o cost/$(COST).o + +cool/$(COOL).o: cool/$(COOL).f + $(FC) $(FFLAGS) -c cool/$(COOL).f -o cool/$(COOL).o + +perm/$(PERM).o: perm/$(PERM).f + $(FC) $(FFLAGS) -c perm/$(PERM).f -o perm/$(PERM).o diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cool/exp.f b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cool/exp.f new file mode 100644 index 0000000..e0da2d1 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cool/exp.f @@ -0,0 +1,127 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c part of the randomize-package for constraint surrogates +c exponential cooling scheme +c author T. Schreiber (1999) +c +c------------------------------------------------------------------- +c get options specific for cooling scheme +C + subroutine opts_cool() + common /coolcom/ + . itini,tini,iafac,afac,cgoal,mtot,msucc,ntot,nsucc,mstop + + tini=fcan("T",0.) + afac=fcan("a",0.) + mtot=ican("S",20000) + msucc=ican("s",2000) + mstop=ican("z",200) + cgoal=fcan("C",0.) + end + +c------------------------------------------------------------------- +c print version information on cooling scheme +C + subroutine what_cool() + call ptext("Cooling scheme: exponential") + end + +c------------------------------------------------------------------- +c print usage message specific for cooling scheme +C + subroutine usage_cool() + call ptext("Cooling options: [-T# -a# -S# -s# -z# -C#]") + call popt("T","initial temperature (auto)") + call popt("a","cooling factor (auto)") + call popt("S","total steps before cooling (20000)") + call popt("s","successful steps before cooling (2000)") + call popt("z","minimal successful steps before cooling (200)") + call popt("C","goal value of cost function (0.0)") + end + +c------------------------------------------------------------------- +c initialise all that is needed for cooling scheme +C + function cool_init() + common /coolcom/ + . itini,tini,iafac,afac,cgoal,mtot,msucc,ntot,nsucc,mstop + + ntot=0 + nsucc=0 + itini=1 + if(tini.eq.0.) then + tini=1e-4 + itini=0 + endif + iafac=1 + if(afac.eq.0.) then + afac=0.5 + iafac=0 + endif + temp=tini + cool_init=temp + end + +c------------------------------------------------------------------- +c determine new temperature depending on current cost function, +c acceptance status and history +c par can be used to pass information to the permutation scheme +c + function cool(iaccept,iend,iv) + common /coolcom/ + . itini,tini,iafac,afac,cgoal,mtot,msucc,ntot,nsucc,mstop + common nmax,cost,temp,cmin,rate + + iend=0 + cool=temp + nsucc=nsucc+iaccept + ntot=ntot+1 + if(ntot.lt.mtot.and.nsucc.lt.msucc) return + rate=real(nsucc)/real(ntot) + iend=1 + if(cost.le.cgoal) return + if(itini.eq.0.and.temp.eq.tini.and.ntot.gt.1.5*nsucc) then + tini=10*temp + if(iv.ne.0) write(istderr(),*) + . "increased initial temperature from ", + . temp, " to ", tini, " for melting" + temp=tini + else if(nsucc.le.mstop) then + if(iafac.eq.1) return + afac=sqrt(afac) + mtot=mtot*sqrt(2.) + temp=tini + if(iv.ne.0) write(istderr(),*) "starting over: " + if(iv.ne.0) write(istderr(),*) " Cooling rate: ", afac, + . " S:", mtot, " s: ", msucc + else + temp=temp*afac + if(iv.ne.0) write(istderr(), + . '(3hT: ,g15.6,4h S: ,i15,4h s: , i15,8h cost: ,g15.6)') + . temp, ntot, nsucc, cost + endif + iend=0 + ntot=0 + nsucc=0 + cool=temp + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/auto.f b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/auto.f new file mode 100644 index 0000000..7a4810c --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/auto.f @@ -0,0 +1,174 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c part of the TISEAN randomize package for constraint surrogates +c cost function +c autocorrelation function +c author T. Schreiber (1999) +c +c------------------------------------------------------------------- +c get cost function specific options +c + subroutine opts_cost(ncol) + parameter(mlag=100000) + dimension c0(mlag), c(mlag) + common /costcom/ nlag, c0, c, sd, sc, iweight + + nlag=imust('D') + iweight=ican('W',0) + ncol=1 + end + +c------------------------------------------------------------------- +c print version information on cost function +c + subroutine what_cost() + call ptext("Cost function: autocorrelation") + end + +c------------------------------------------------------------------- +c print cost function specific usage message +c + subroutine usage_cost() + call ptext("Cost function options: -D# [-W#]") + call popt("D","number of lags") + call popt("W", + . "average: 0=max(c) 1=|c|/lag 2=(c/lag)**2 3=max(c)/lag (0)") + end + +c------------------------------------------------------------------- +c initialise all that is needed for cost function +c + subroutine cost_init() + parameter(mlag=100000) + dimension c0(mlag), c(mlag) + common /costcom/ nlag, c0, c, sd, sc, iweight + + if(nlag.gt.mlag) write(istderr(),'(a)') + . "truncated to ", mlag," lags" + nlag=min(mlag,nlag) + call auto(nlag,c0) + end + +c------------------------------------------------------------------- +c initial transformation on time series and its inverse +c + subroutine cost_transform(nmax,mcmax,nxdum,x) + dimension x(nmax) + parameter(mlag=100000) + dimension c0(mlag), c(mlag) + common /costcom/ nlag, c0, c, sd, sc, iweight + + call normal1(nmax,x,sc,sd) + end + + subroutine cost_inverse(nmax,mcmax,nxdum,x,y) + dimension x(nmax), y(nmax) + parameter(mlag=100000) + dimension c0(mlag), c(mlag) + common /costcom/ nlag, c0, c, sd, sc, iweight + + do 10 n=1,nmax + 10 y(n)=x(n)*sd+sc + end + +c------------------------------------------------------------------- +c compute full cost function from scratch +c + subroutine cost_full(iv) + parameter(mlag=100000) + dimension c0(mlag), c(mlag) + common /costcom/ nlag, c0, c, sd, sc, iweight + common nmax,cost + + call auto(nlag,c) + cc=0 + do 10 n=1,nlag + 10 call aver(cc,c0(n)-c(n),n) + cost=cc + end + +c------------------------------------------------------------------- +c compute changed cost function on exchange of n1 and n2 +c + subroutine cost_update(nn1,nn2,cmax,iaccept,iv) + parameter(mlag=100000,nx=100000) + dimension c0(mlag), c(mlag), ccop(mlag), x(nx) + common /costcom/ nlag, c0, c, sd, sc, iweight + common nmax,cost,temp,cmin,rate,x + + n1=min(nn1,nn2) + n2=max(nn1,nn2) + comp=0 + iaccept=0 + do 10 n=1,nlag + cc=c(n) + dx=x(n2)-x(n1) + if(n1-n.ge.1) cc=cc+dx*x(n1-n) + if(n2+n.le.nmax) cc=cc-dx*x(n2+n) + if(n2-n1.eq.n) goto 1 + if(n1+n.le.nmax) cc=cc+dx*x(n1+n) + if(n2-n.ge.1) cc=cc-dx*x(n2-n) + 1 call aver(comp,c0(n)-cc,n) + if(comp.ge.cmax) return + 10 ccop(n)=cc + cost=comp ! if got here: accept + iaccept=1 + call exch(n1,n2) + do 20 n=1,nlag + 20 c(n)=ccop(n) + end + +c------------------------------------------------------------------- +c compute autocorrelation from scratch +c + subroutine auto(nlag,c) + parameter(nx=100000) + dimension c(*), x(nx) + common nmax,cost,temp,cmin,rate,x + + do 10 n=1,nlag + cc=0 + do 20 i=n+1,nmax + 20 cc=cc+x(i-n)*x(i) + 10 c(n)=cc + end + +c------------------------------------------------------------------- +c weighted average of autocorrelation +c + subroutine aver(cav,dc,n) + parameter(mlag=100000) + dimension c0(mlag), c(mlag) + common /costcom/ nlag, c0, c, sd, sc, iweight + common nmax + + if(iweight.eq.0) then + cav=max(cav,abs(dc)/real(nmax-n)) + else if(iweight.eq.1) then + cav=cav+abs(dc)/real((nmax-n)*n) + else if(iweight.eq.2) then + cav=cav+(dc/real((nmax-n)*n))**2 + else + cav=max(cav,abs(dc)/real((nmax-n)*n)) + endif + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/autop.f b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/autop.f new file mode 100644 index 0000000..546342c --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/autop.f @@ -0,0 +1,181 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c part of the TISEAN randomize package for constraint surrogates +c cost function +c autocorrelation function with periodic continuation +c author T. Schreiber (1999) +c +c------------------------------------------------------------------- +c get cost function specific options +c + subroutine opts_cost(ncol) + parameter(mlag=100000) + dimension c0(mlag), c(mlag) + common /costcom/ nlag, c0, c, sd, sc, iweight + + nlag=imust('D') + iweight=ican('W',0) + ncol=1 + end + +c------------------------------------------------------------------- +c print version information on cost function +c + subroutine what_cost() + call ptext("Cost function: periodic autocorrelation") + end + +c------------------------------------------------------------------- +c print cost function specific usage message +c + subroutine usage_cost() + call ptext("Cost function options: -D# [-W#]") + call popt("D","number of lags") + call popt("W", + . "average: 0=max(c) 1=|c|/lag 2=(c/lag)**2 3=max(c)/lag (0)") + end + +c------------------------------------------------------------------- +c initialise all that is needed for cost function +c + subroutine cost_init() + parameter(mlag=100000) + dimension c0(mlag), c(mlag) + common /costcom/ nlag, c0, c, sd, sc, iweight + + if(nlag.gt.mlag) write(istderr(),'(a)') + . "truncated to ", mlag," lags" + nlag=min(mlag,nlag) + call auto(nlag,c0) + end + +c------------------------------------------------------------------- +c initial transformation on time series and its inverse +c + subroutine cost_transform(nmax,mcmax,nxdum,x) + dimension x(nmax) + parameter(mlag=100000) + dimension c0(mlag), c(mlag) + common /costcom/ nlag, c0, c, sd, sc, iweight + + call normal1(nmax,x,sc,sd) + end + + subroutine cost_inverse(nmax,mcmax,nxdum,x,y) + dimension x(nmax), y(nmax) + parameter(mlag=100000) + dimension c0(mlag), c(mlag) + common /costcom/ nlag, c0, c, sd, sc, iweight + + do 10 n=1,nmax + 10 y(n)=x(n)*sd+sc + end + +c------------------------------------------------------------------- +c compute full cost function from scratch +c + subroutine cost_full(iv) + parameter(mlag=100000) + dimension c0(mlag), c(mlag) + common /costcom/ nlag, c0, c, sd, sc, iweight + common nmax,cost + + call auto(nlag,c) + cc=0 + do 10 n=1,nlag + 10 call aver(cc,c0(n)-c(n),n) + cost=cc + end + +c------------------------------------------------------------------- +c compute changed cost function on exchange of n1 and n2 +c + subroutine cost_update(n1,n2,cmax,iaccept,iv) + parameter(mlag=100000,nx=100000) + dimension c0(mlag), c(mlag), ccop(mlag), x(nx) + common /costcom/ nlag, c0, c, sd, sc, iweight + common nmax,cost,temp,cmin,rate,x + + comp=0 + iaccept=0 + do 10 n=1,nlag + cc=c(n) + dx=x(n2)-x(n1) + nd1=n1-n + if(nd1.lt.1) nd1=nd1+nmax + if(nd1.ne.n2) cc=cc+dx*x(nd1) + nu1=n1+n + if(nu1.gt.nmax) nu1=nu1-nmax + if(nu1.ne.n2) cc=cc+dx*x(nu1) + nd2=n2-n + if(nd2.lt.1) nd2=nd2+nmax + if(nd2.ne.n1) cc=cc-dx*x(nd2) + nu2=n2+n + if(nu2.gt.nmax) nu2=nu2-nmax + if(nu2.ne.n1) cc=cc-dx*x(nu2) + call aver(comp,c0(n)-cc,n) + if(comp.ge.cmax) return + 10 ccop(n)=cc + cost=comp ! if got here: accept + iaccept=1 + call exch(n1,n2) + do 20 n=1,nlag + 20 c(n)=ccop(n) + end + +c------------------------------------------------------------------- +c compute autocorrelation from scratch +c + subroutine auto(nlag,c) + parameter(nx=100000) + dimension c(*), x(nx) + common nmax,cost,temp,cmin,rate,x + + do 10 n=1,nlag + cc=0 + do 20 i=1,nmax + ii=i-n + if(ii.lt.1) ii=ii+nmax + 20 cc=cc+x(ii)*x(i) + 10 c(n)=cc + end + +c------------------------------------------------------------------- +c weighted average of autocorrelation +c + subroutine aver(cav,dc,n) + parameter(mlag=100000) + dimension c0(mlag), c(mlag) + common /costcom/ nlag, c0, c, sd, sc, iweight + common nmax + + if(iweight.eq.0) then + cav=max(cav,abs(dc)/real(nmax)) + else if(iweight.eq.1) then + cav=cav+abs(dc)/real(nmax*n) + else if(iweight.eq.2) then + cav=cav+(dc/real(nmax*n))**2 + else + cav=max(cav,abs(dc)/real(nmax*n)) + endif + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/spikeauto.f b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/spikeauto.f new file mode 100644 index 0000000..063e82c --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/spikeauto.f @@ -0,0 +1,265 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c part of the TISEAN randomize package for constraint surrogates +c cost function +c binned spike train autocorrelation function +c author T. Schreiber (1999) +c +c------------------------------------------------------------------- +c get cost function specific options +c + subroutine opts_cost(ncol) + parameter(nhist=100000) + dimension ihist0(nhist), ihist(nhist) + common /costcom/ inter, bininv, nbin, ihist0, ihist, iweight + + iweight=ican('W',0) + bininv=1./fmust("d") + totbin=fmust("D") + nbin=min(int(totbin*bininv)+1,nhist) + inter=lopt("i",1) + ncol=1 + end + +c------------------------------------------------------------------- +c print version information on cost function +c + subroutine what_cost() + call ptext("Cost function: spike train autocorrelation function") + end + +c------------------------------------------------------------------- +c print cost function specific usage message +c + subroutine usage_cost() + call ptext("Cost function options: -d# -D# [-i -W#]") + call popt("d","time span of one bin") + call popt("D","total time spanned") + call popt("i","expect intervals rather than times") + call popt("W", + . "average: 0=max(c) 1=|c|/lag 2=(c/lag)**2 (0)") + end + +c------------------------------------------------------------------- +c initialise all that is needed for cost function +c + subroutine cost_init() + parameter(nhist=100000) + dimension ihist0(nhist), ihist(nhist) + common /costcom/ inter, bininv, nbin, ihist0, ihist, iweight + + call sauto(nbin,bininv,ihist0) + end + +c------------------------------------------------------------------- +c initial transformation on time series and its inverse +c here: series internally stored as intervals +c + subroutine cost_transform(nmax,mcmax,nxdum,x) + parameter(nx=100000) + parameter(nhist=100000) + dimension ihist0(nhist), ihist(nhist) + common /costcom/ inter, bininv, nbin, ihist0, ihist, iweight + dimension nxclu(nx) + common /permutecom/ mxclu, nxclu + dimension x(*), lx(nx) + + if(inter.eq.1) return + call sort(nmax,x,lx) + do 10 n=nmax,2,-1 + 10 x(n)=x(n)-x(n-1) + mxclu=mxclu+1 + nxclu(mxclu)=1 + end + + subroutine cost_inverse(nmax,mcmax,nxdum,x,y) + parameter(nhist=100000) + dimension ihist0(nhist), ihist(nhist) + common /costcom/ inter, bininv, nbin, ihist0, ihist, iweight + dimension x(*), y(*) + + do 10 n=1,nmax + 10 y(n)=x(n) + if(inter.eq.1) return + do 20 n=2,nmax + 20 y(n)=y(n)+y(n-1) + end + +c------------------------------------------------------------------- +c compute full cost function from scratch +c + subroutine cost_full(iv) + parameter(nhist=100000) + dimension ihist0(nhist), ihist(nhist) + common /costcom/ inter, bininv, nbin, ihist0, ihist, iweight + common nmax,cost + + call sauto(nbin,bininv,ihist) + cost=aver(ihist0,ihist) + if(iv.ne.0) call dump() + end + +c------------------------------------------------------------------- +c compute changed cost function on exchange of n1 and n2 +c + subroutine cost_update(nn1,nn2,cmax,iaccept,iv) + parameter(nx=100000) + parameter(nhist=100000) + dimension ihist0(nhist), ihist(nhist) + common /costcom/ inter, bininv, nbin, ihist0, ihist, iweight + dimension ihcop(nhist), x(nx) + common nmax,cost,temp,cmin,rate,x + + n1=min(nn1,nn2) + n2=max(nn1,nn2) + comp=0 + iaccept=0 + do 10 i=1,nbin + 10 ihcop(i)=ihist(i) + dx=0 + do 20 nn=n1,1,-1 + if(nn.lt.n1) dx=dx+x(nn) + if(int(dx*bininv)+1.gt.nbin) goto 1 + dxx=dx + do 30 nnn=n1,n2-1 + dxx=dxx+x(nnn) + il=int(dxx*bininv)+1 + if(il.gt.nbin) goto 20 + 30 ihcop(il)=ihcop(il)-1 + 20 continue + 1 dx=0 + do 40 nn=n2,1,-1 + if(nn.lt.n2) dx=dx+x(nn) + if(int(dx*bininv)+1.gt.nbin) goto 2 + dxx=dx + do 50 nnn=n2,nmax + dxx=dxx+x(nnn) + il=int(dxx*bininv)+1 + if(il.gt.nbin) goto 40 + 50 ihcop(il)=ihcop(il)-1 + 40 continue + 2 call exch(n1,n2) + dx=0 + do 60 nn=n1,1,-1 + if(nn.lt.n1) dx=dx+x(nn) + if(int(dx*bininv)+1.gt.nbin) goto 3 + dxx=dx + do 70 nnn=n1,n2-1 + dxx=dxx+x(nnn) + il=int(dxx*bininv)+1 + if(il.gt.nbin) goto 60 + 70 ihcop(il)=ihcop(il)+1 + 60 continue + 3 dx=0 + do 80 nn=n2,1,-1 + if(nn.lt.n2) dx=dx+x(nn) + if(int(dx*bininv)+1.gt.nbin) goto 4 + dxx=dx + do 90 nnn=n2,nmax + dxx=dxx+x(nnn) + il=int(dxx*bininv)+1 + if(il.gt.nbin) goto 80 + 90 ihcop(il)=ihcop(il)+1 + 80 continue + 4 comp=aver(ihist0,ihcop) + if(comp.ge.cmax) then + call exch(n1,n2) + return + endif + cost=comp ! if got here: accept + iaccept=1 + if(iv.ne.0) call panic(ihcop) + do 100 i=1,nbin + 100 ihist(i)=ihcop(i) + end + +c------------------------------------------------------------------- +c compute autocorrealtion from scratch +c + subroutine sauto(nbin,bininv,ihist) + parameter(nx=100000) + dimension ihist(*) + common nmax,cost,temp,cmin,rate,x + dimension x(nx) + + do 10 i=1,nbin + 10 ihist(i)=0 + do 20 n1=1,nmax + dx=0 + do 30 n2=n1,nmax + dx=dx+x(n2) + il=int(dx*bininv)+1 + if(il.gt.nbin) goto 20 + 30 ihist(il)=ihist(il)+1 + 20 continue + end + +c------------------------------------------------------------------- +c weighted average of autocorrelation +c + function aver(ih1,ih2) + parameter(nhist=100000) + dimension ih1(nhist), ih2(nhist) + dimension ihist0(nhist), ihist(nhist) + common /costcom/ inter, bininv, nbin, ihist0, ihist, iweight + + aver=0 + if(iweight.eq.0) then + do 10 i=1,nbin + 10 aver=max(aver,real(abs(ih1(i)-ih2(i)))) + else if(iweight.eq.1) then + do 20 i=1,nbin + 20 aver=aver+real(abs(ih1(i)-ih2(i)))/real(i) + else if(iweight.eq.2) then + do 30 i=1,nbin + 30 aver=aver+(ih1(i)-ih2(i))**2/real(i) + endif + end + +c------------------------------------------------------------------- +c diagnostic output +c + subroutine dump() + parameter(nhist=100000) + dimension ihist0(nhist), ihist(nhist) + common /costcom/ inter, bininv, nbin, ihist0, ihist, iweight + + write(istderr(),'(5hgoal ,4i12)') (ihist0(n),n=1,min(4,nbin)) + write(istderr(),'(5his ,4i12)') (ihist(n),n=1,min(4,nbin)) + write(istderr(),'(5hmiss ,4i12)') + . (abs(ihist0(n)-ihist(n)),n=1,min(4,nbin)) + write(istderr(),'()') + end + + subroutine panic(ihcop) + parameter(nhist=100000) + dimension ihist0(nhist), ihist(nhist) + common /costcom/ inter, bininv, nbin, ihist0, ihist, iweight + dimension ihcop(*) + + call cost_full(0) + write(istderr(),'(7hupdate ,4i12)') (ihcop(n),n=1,min(4,nbin)) + write(istderr(),'(7hfresh ,4i12)') (ihist(n),n=1,min(4,nbin)) + write(istderr(),'(7hdiscr ,4i12)') + . (abs(ihcop(n)-ihist(n)),n=1,min(4,nbin)) + write(istderr(),'()') + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/spikespec.f b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/spikespec.f new file mode 100644 index 0000000..26cd874 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/spikespec.f @@ -0,0 +1,251 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c part of the TISEAN randomize package for constraint surrogates +c cost function +c spike train power spectrum +c author T. Schreiber (1999) +c +c------------------------------------------------------------------- +c get cost function specific options +c + subroutine opts_cost(ncol) + parameter(mfreq=100000) + dimension sp0r(mfreq), sp0i(mfreq), spr(mfreq), spi(mfreq), + . sp0(mfreq), sp(mfreq) + common /costcom/ nfreq, fmax, inter, + . sp0r, sp0i, sp0, spr, spi, sp, sd, sc, iweight + + iweight=ican('W',0) + fmax=fcan("F",0) + nfreq=ican("#",0) + inter=lopt("i",1) + ncol=1 + end + +c------------------------------------------------------------------- +c print version information on cost function +c + subroutine what_cost() + call ptext("Cost function: spike train power spectrum") + end + +c------------------------------------------------------------------- +c print cost function specific usage message +c + subroutine usage_cost() + call ptext("Cost function options: [-F# -## -w# -i]") + call popt("W", + . "average: 0=max(s) 1=|s|/f 2=(s/f)**2 3=|s| (0)") + call popt("F","maximal frequency (2*l / total time)") + call popt("#","number of frequencies (F* total time /2)") + call popt("w","frequency resolution (0)") + call popt("i","expect intervals rather than times") + end + +c------------------------------------------------------------------- +c initialise all that is needed for cost function +c + subroutine cost_init() + parameter(nx=100000,mfreq=100000) + dimension sp0r(mfreq), sp0i(mfreq), spr(mfreq), spi(mfreq), + . sp0(mfreq), sp(mfreq) + common /costcom/ nfreq, fmax, inter, + . sp0r, sp0i, sp0, spr, spi, sp, sd, sc, iweight + dimension x(nx) + common nmax,cost,temp,cmin,rate,x + + if(fmax.le.0.) fmax=2*nmax/(x(nmax)-x(1)) + if(nfreq.le.0) nfreq=fmax*(x(nmax)-x(1))/2 + if(nfreq.gt.mfreq) write(istderr(),'(a)') + . "truncated to ", mfreq," frequencies" + nfreq=min(mfreq,nfreq) + write(istderr(),*) "randomize_spikespec: total time covered: ", + . x(nmax)-x(1) + write(istderr(),*) "randomize_spikespec: computing ", nfreq, + . " frequencies up to ", fmax + call sspect(nfreq,fmax/nfreq,sp0r,sp0i,sp0) + end + +c------------------------------------------------------------------- +c initial transformation on time series and its inverse +c + subroutine cost_transform(nmax,mcmax,nxdum,x) + parameter(mfreq=100000,nx=100000) + dimension sp0r(mfreq), sp0i(mfreq), spr(mfreq), spi(mfreq), + . sp0(mfreq), sp(mfreq) + common /costcom/ nfreq, fmax, inter, + . sp0r, sp0i, sp0, spr, spi, sp, sd, sc, iweight + dimension x(nx), lx(nx) + + if(inter.eq.0) goto 1 + do 10 n=2,nmax + 10 x(n)=x(n)+x(n-1) + 1 call sort(nmax,x,lx) + end + + subroutine cost_inverse(nmax,mcmax,nxdum,x,y) + parameter(mfreq=100000) + dimension sp0r(mfreq), sp0i(mfreq), spr(mfreq), spi(mfreq), + . sp0(mfreq), sp(mfreq) + common /costcom/ nfreq, fmax, inter, + . sp0r, sp0i, sp0, spr, spi, sp, sd, sc, iweight + dimension x(nmax), y(nmax) + + do 10 n=1,nmax + 10 y(n)=x(n) + if(inter.ne.1) return + do 20 n=nmax,2,-1 + 20 y(n)=y(n)-y(n-1) + end + +c------------------------------------------------------------------- +c compute full cost function from scratch +c + subroutine cost_full(iv) + parameter(mfreq=100000) + dimension sp0r(mfreq), sp0i(mfreq), spr(mfreq), spi(mfreq), + . sp0(mfreq), sp(mfreq) + common /costcom/ nfreq, fmax, inter, + . sp0r, sp0i, sp0, spr, spi, sp, sd, sc, iweight + common nmax,cost + + call sspect(nfreq,fmax/nfreq,spr,spi,sp) + + cc=0 + do 10 i=1,nfreq + 10 call aver(cc,sp(i)-sp0(i),i) + cost=cc + if(iv.ne.0) call dump() + end + +c------------------------------------------------------------------- +c compute changed cost function on exchange of n1 and n2 +c + subroutine cost_update(n1,n2,cmax,iaccept,iv) + parameter(mfreq=100000,nx=100000) + dimension sp0r(mfreq), sp0i(mfreq), spr(mfreq), spi(mfreq), + . sp0(mfreq), sp(mfreq) + common /costcom/ nfreq, fmax, inter, + . sp0r, sp0i, sp0, spr, spi, sp, sd, sc, iweight + dimension sprcop(mfreq), spicop(mfreq), spcop(mfreq), x(nx) + common nmax,cost,temp,cmin,rate,x + data pi/3.1415926/ + + comp=0 + iaccept=0 + do 10 i=1,nfreq + f=i*(fmax/nfreq) + omega=2*pi*f + xx=x(n1-1)+x(n1+1)-x(n1) + sprcop(i)=spr(i)-cos(omega*x(n1))+cos(omega*xx) + spicop(i)=spi(i)-sin(omega*x(n1))+sin(omega*xx) + spcop(i)=sprcop(i)**2+spicop(i)**2 + call aver(comp,sp0(i)-spcop(i),i) + 10 if(comp.ge.cmax) return + cost=comp ! if got here: accept + iaccept=1 + call exch(n1,n2) + if(iv.ne.0) call panic(spcop) + do 20 i=1,nfreq + spr(i)=sprcop(i) + spi(i)=spicop(i) + 20 sp(i)=spcop(i) + end + +c------------------------------------------------------------------- +c compute spectrum from scratch +c + subroutine sspect(nfreq,fres,spr,spi,sp) + parameter(nx=100000) + dimension spr(*), spi(*), sp(*), x(nx) + common nmax,cost,temp,cmin,rate,x + data pi/3.1415926/ + + do 10 i=1,nfreq + f=i*fres + omega=2*pi*f + sr=0 + si=0 + do 20 n=1,nmax + sr=sr+cos(omega*x(n)) + 20 si=si+sin(omega*x(n)) + spr(i)=sr + spi(i)=si + 10 sp(i)=sr**2+si**2 + end + +c------------------------------------------------------------------- +c weighted average of autocorrelation +c + subroutine aver(cav,dc,n) + parameter(mfreq=100000) + dimension sp0r(mfreq), sp0i(mfreq), spr(mfreq), spi(mfreq), + . sp0(mfreq), sp(mfreq) + common /costcom/ nfreq, fmax, inter, + . sp0r, sp0i, sp0, spr, spi, sp, sd, sc, iweight + + if(iweight.eq.0) then + cav=max(cav,abs(dc)) ! max (L-infinity) norm + else if(iweight.eq.1) then + cav=cav+abs(dc)/n ! L-1 norm (sum of moduli), weighted by freq. + else if(iweight.eq.2) then + cav=cav+(dc/n)**2 ! L-2 norm (sum of squares), weighted by freq. + else if(iweight.eq.2) then + cav=cav+abs(dc) ! L-1 norm (sum of moduli) + endif + end + +c------------------------------------------------------------------- +c diagnostic output +c + subroutine dump() + parameter(mfreq=100000) + dimension sp0r(mfreq), sp0i(mfreq), spr(mfreq), spi(mfreq), + . sp0(mfreq), sp(mfreq) + common /costcom/ nfreq, fmax, inter, + . sp0r, sp0i, sp0, spr, spi, sp, sd, sc, iweight + common nmax + + write(istderr(),'(5hgoal ,4f9.3)') (sp0(n),n=1,min(4,nfreq)) + write(istderr(),'(5his ,4f9.3)') (sp(n),n=1,min(4,nfreq)) + write(istderr(),'(5hmiss ,4f9.3)') + . ((sp0(n)-sp(n)),n=1,min(4,nfreq)) + write(istderr(),'()') + end + + subroutine panic(spcop) + parameter(mfreq=100000) + dimension spcop(*) + dimension sp0r(mfreq), sp0i(mfreq), spr(mfreq), spi(mfreq), + . sp0(mfreq), sp(mfreq) + common /costcom/ nfreq, fmax, inter, + . sp0r, sp0i, sp0, spr, spi, sp, sd, sc, iweight + common nmax + + call cost_full(0) + write(istderr(),'(7hupdate ,4f9.3)') + . (spcop(n),n=1,min(4,nfreq)) + write(istderr(),'(7hfresh ,4f9.3)') (sp(n),n=1,min(4,nfreq)) + write(istderr(),'(7hdiscr ,4f9.3)') + . ((spcop(n)-sp(n)),n=1,min(4,nfreq)) + write(istderr(),'()') + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/uneven.f b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/uneven.f new file mode 100644 index 0000000..98460f2 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/cost/uneven.f @@ -0,0 +1,260 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c part of the TISEAN randomize package for constraint surrogates +c cost function +c binned autocorrelation function of unevenly sampled data +c author T. Schreiber (1999) +c +c------------------------------------------------------------------- +c get cost function specific options +c + subroutine opts_cost(ncol) + parameter(nhist=100000,nx=100000) + dimension hnorm(nhist), h0(nhist), h(nhist) + character*80 filet + common /costcom/ bininv, nbin, hnorm, h0, h, sd, sc, iweight + + iweight=ican('W',0) + bininv=1./fmust("d") + totbin=fmust("D") + nbin=min(int(totbin*bininv)+1,nhist) + ncol=2 + end + +c------------------------------------------------------------------- +c print version information on cost function +c + subroutine what_cost() + call ptext("Cost function: binned autocorrelation function") + end + +c------------------------------------------------------------------- +c print cost function specific usage message +c + subroutine usage_cost() + call ptext("Cost function options: -d# -D# [-W#]") + call popt("d","time span of one bin") + call popt("D","total time spanned") + call popt("W", + . "average: 0=max(c) 1=|c|/lag 2=(c/lag)**2 (0)") + end + +c------------------------------------------------------------------- +c initialise all that is needed for cost function +c + subroutine cost_init() + parameter(nhist=100000,nx=100000) + dimension hnorm(nhist), h0(nhist), h(nhist), x(nx,2) + common /costcom/ bininv, nbin, hnorm, h0, h, sd, sc, iweight + common nmax,cost,temp,cmin,rate,x + + do 10 i=1,nbin + 10 hnorm(i)=0. + do 20 n1=1,nmax + do 30 n2=n1,nmax + il=int((x(n2,2)-x(n1,2))*bininv)+1 + if(il.gt.nbin) goto 20 + 30 hnorm(il)=hnorm(il)+1. + 20 continue + do 40 i=1,nbin + 40 if(hnorm(i).gt.0.) hnorm(i)=1./hnorm(i) + call sauto(nbin,bininv,h0) + end + +c------------------------------------------------------------------- +c initial transformation on time series and its inverse +c here: sort by increasing sample times, no inversion necessary +c also normalise to unit variance, zero mean +c + subroutine cost_transform(nmax,mcmax,nxdum,x) + parameter(nhist=100000,nx=100000) + dimension hnorm(nhist), h0(nhist), h(nhist) + common /costcom/ bininv, nbin, hnorm, h0, h, sd, sc, iweight + dimension x(nxdum,2), lx(nx) + + call indexx(nmax,x(1,2),lx) + call index2sort(nmax,x(1,2),lx) + call index2sort(nmax,x,lx) + call normal1(nmax,x,sc,sd) + end + + subroutine cost_inverse(nmax,mcmax,nxdum,x,y) + dimension x(nxdum,2), y(nxdum,2) + parameter(nhist=100000,nx=100000) + dimension hnorm(nhist), h0(nhist), h(nhist) + common /costcom/ bininv, nbin, hnorm, h0, h, sd, sc, iweight + + do 10 n=1,nmax + y(n,2)=x(n,2) + 10 y(n,1)=x(n,1)*sd+sc + end + +c------------------------------------------------------------------- +c compute full cost function from scratch +c + subroutine cost_full(iv) + parameter(nhist=100000,nx=100000) + dimension hnorm(nhist), h0(nhist), h(nhist) + common /costcom/ bininv, nbin, hnorm, h0, h, sd, sc, iweight + common nmax,cost + + call sauto(nbin,bininv,h) + cost=aver(h0,h) + if(iv.ne.0) call dump() + end + +c------------------------------------------------------------------- +c compute changed cost function on exchange of n1 and n2 +c + subroutine cost_update(nn1,nn2,cmax,iaccept,iv) + parameter(nhist=100000,nx=100000) + dimension hnorm(nhist), h0(nhist), h(nhist) + common /costcom/ bininv, nbin, hnorm, h0, h, sd, sc, iweight + dimension hcop(nhist), x(nx,2) + common nmax,cost,temp,cmin,rate,x + + n1=min(nn1,nn2) + n2=max(nn1,nn2) + comp=0 + iaccept=0 + do 10 i=1,nbin + 10 hcop(i)=h(i) + do 20 nn=n1-1,1,-1 + il=int((x(n1,2)-x(nn,2))*bininv)+1 + if(il.gt.nbin) goto 1 + 20 hcop(il)=hcop(il)-x(n1,1)*x(nn,1) + 1 continue + do 30 nn=n1,nmax + il=int((x(nn,2)-x(n1,2))*bininv)+1 + if(il.gt.nbin) goto 2 + 30 if(nn.ne.n2) hcop(il)=hcop(il)-x(nn,1)*x(n1,1) + 2 continue + do 40 nn=n2-1,1,-1 + il=int((x(n2,2)-x(nn,2))*bininv)+1 + if(il.gt.nbin) goto 3 + 40 hcop(il)=hcop(il)-x(n2,1)*x(nn,1) + 3 continue + do 50 nn=n2,nmax + il=int((x(nn,2)-x(n2,2))*bininv)+1 + if(il.gt.nbin) goto 4 + 50 hcop(il)=hcop(il)-x(nn,1)*x(n2,1) + 4 call exch(n1,n2) + do 60 nn=n1-1,1,-1 + il=int((x(n1,2)-x(nn,2))*bininv)+1 + if(il.gt.nbin) goto 5 + 60 hcop(il)=hcop(il)+x(n1,1)*x(nn,1) + 5 continue + do 70 nn=n1,nmax + il=int((x(nn,2)-x(n1,2))*bininv)+1 + if(il.gt.nbin) goto 6 + 70 if(nn.ne.n2) hcop(il)=hcop(il)+x(nn,1)*x(n1,1) + 6 continue + do 80 nn=n2-1,1,-1 + il=int((x(n2,2)-x(nn,2))*bininv)+1 + if(il.gt.nbin) goto 7 + 80 hcop(il)=hcop(il)+x(n2,1)*x(nn,1) + 7 continue + do 90 nn=n2,nmax + il=int((x(nn,2)-x(n2,2))*bininv)+1 + if(il.gt.nbin) goto 8 + 90 hcop(il)=hcop(il)+x(nn,1)*x(n2,1) + 8 comp=aver(h0,hcop) + if(comp.ge.cmax) then + call exch(n1,n2) + return + endif + cost=comp ! if got here: accept + iaccept=1 + if(iv.ne.0) call panic(hcop) + do 100 i=1,nbin + 100 h(i)=hcop(i) + end + +c------------------------------------------------------------------- +c compute autocorrealtion from scratch +c + subroutine sauto(nbin,bininv,h) + parameter(nx=100000) + dimension h(*) + common nmax,cost,temp,cmin,rate,x + dimension x(nx,2) + + do 10 i=1,nbin + 10 h(i)=0 + do 20 n1=1,nmax + do 30 n2=n1,nmax + il=int((x(n2,2)-x(n1,2))*bininv)+1 + if(il.gt.nbin) goto 20 + 30 h(il)=h(il)+x(n2,1)*x(n1,1) + 20 continue + end + +c------------------------------------------------------------------- +c weighted average of autocorrelation +c + function aver(h1,h2) + parameter(nhist=100000,nx=100000) + dimension hnorm(nhist), h0(nhist), h(nhist), + . h1(*), h2(*) + common /costcom/ bininv, nbin, hnorm, h0, h, sd, sc, iweight + + aver=0 + if(iweight.eq.0) then + do 10 i=1,nbin + 10 aver=max(aver,abs((h1(i)-h2(i))*hnorm(i))) + else if(iweight.eq.1) then + do 20 i=1,nbin + 20 aver=aver+abs((h1(i)-h2(i))*hnorm(i))/real(i) + else if(iweight.eq.2) then + do 30 i=1,nbin + 30 aver=aver+((h1(i)-h2(i))*hnorm(i))**2/real(i) + endif + end + +c------------------------------------------------------------------- +c diagnostic output +c + subroutine dump() + parameter(nhist=100000,nx=100000) + dimension hnorm(nhist), h0(nhist), h(nhist) + common /costcom/ bininv, nbin, hnorm, h0, h, sd, sc, iweight + + write(istderr(),'(5hgoal ,4g15.5)') (h0(n),n=1,min(4,nbin)) + write(istderr(),'(5his ,4g15.5)') (h(n),n=1,min(4,nbin)) + write(istderr(),'(5hmiss ,4g15.5)') + . (abs(h0(n)-h(n)),n=1,min(4,nbin)) + write(istderr(),'()') + end + + subroutine panic(hcop) + parameter(nhist=100000,nx=100000) + dimension hnorm(nhist), h0(nhist), h(nhist) + common /costcom/ bininv, nbin, hnorm, h0, h, sd, sc, iweight + dimension hcop(*) + + call cost_full(0) + write(istderr(),'(7hupdate ,4g15.5)') (hcop(n),n=1,min(4,nbin)) + write(istderr(),'(7hfresh ,4g15.5)') (h(n),n=1,min(4,nbin)) + write(istderr(),'(7hdiscr ,4g15.5)') + . (abs(hcop(n)-h(n)),n=1,min(4,nbin)) + write(istderr(),'()') + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/perm/event.f b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/perm/event.f new file mode 100644 index 0000000..96f2999 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/perm/event.f @@ -0,0 +1,81 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c part of the TISEAN randomize package for constraint surrogates +C permutation scheme for event times +c one event time is changed such that the two adjacent intervals are swapped +c author T. Schreiber (1999) +c +c------------------------------------------------------------------- +c get permutation specific options +c + subroutine opts_permute() + end + +c------------------------------------------------------------------- +c print version information on permutation scheme +c + subroutine what_permute() + call ptext("Permutation scheme: event time preserving intervals") + end + +c------------------------------------------------------------------- +c print permutation specific usage message +c + subroutine usage_permute() + end + +c------------------------------------------------------------------- +c initialise all that is needed for permutation scheme +c + subroutine permute_init() + parameter(nx=100000) + dimension x(nx) + common nmax,cost,temp,cmin,rate,x + + do 10 n=1,nmax*log(nmax*1.) + call permute(n1,n2) + 10 call exch(n1,n2) + end + +c------------------------------------------------------------------- +c find two indices n1, n2 to be exchanged, maybe using a parameter +c par provided by the cooling schedule +c +c here, n2 is not used at all; event 1 and nmax are never changed +c + subroutine permute(n1,n2) + common nmax + external rand + + n1=min(int(rand(0.0)*nmax)+2,nmax-1) + end + +c------------------------------------------------------------------- +c given two indices n1, n2, actually perform the exchange +c + subroutine exch(n1,n2) + parameter(nx=100000) + dimension x(nx) + common nmax,cost,temp,cmin,rate,x + + x(n1)=x(n1-1)+x(n1+1)-x(n1) + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/perm/random.f b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/perm/random.f new file mode 100644 index 0000000..e8c318f --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/perm/random.f @@ -0,0 +1,109 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c part of the TISEAN randomize package for constraint surrogates +c permutation scheme that swaps to randomly chosen data points +c this may also be used as a template for your own attempts +c author T. Schreiber (1999) +c +c------------------------------------------------------------------- +c get permutation specific options +c + subroutine opts_permute() + parameter(nx=100000) + dimension nxclu(nx) + character*80 filex + common /permutecom/ mxclu, nxclu + + call stcan('X',filex,' ') + mxclu=0 + if(filex.eq." ") return + open(10,file=filex,status="old",err=999) + 1 read(10,*,err=999,end=998) nn + mxclu=mxclu+1 + nxclu(mxclu)=nn + goto 1 + 998 return + 999 write(istderr(),'(a)') "permute: cannot open "//filex + stop + end + +c------------------------------------------------------------------- +c print version information on permutation scheme +c + subroutine what_permute() + call ptext("Permutation scheme: random pairs") + end + +c------------------------------------------------------------------- +c print permutation specific usage message +c + subroutine usage_permute() + call ptext("Permutation options: [-X xfile]") + call popt("X", "list of indices excluded from permutation") + end + +c------------------------------------------------------------------- +c initialise all that is needed for permutation scheme +c + subroutine permute_init() + parameter(nx=100000) + dimension x(nx) + common nmax,cost,temp,cmin,rate,x + + if(nmax.gt.nx) stop "permute: make nx larger." + do 10 i=1,nmax + call permute(n1,n2) + 10 call exch(n1,n2) + end + +c------------------------------------------------------------------- +c find two indices n1, n2 to be exchanged, maybe using a parameter +c par provided by the cooling schedule +c + subroutine permute(n1,n2) + parameter(nx=100000) + dimension nxclu(nx) + common /permutecom/ mxclu, nxclu + common nmax + external rand + + 1 n1=min(int(rand(0.0)*nmax)+1,nmax) + do 10 n=1,mxclu + 10 if(n1.eq.nxclu(n)) goto 1 + 2 n2=min(int(rand(0.0)*nmax)+1,nmax) + if(n2.eq.n1) goto 2 + do 20 n=1,mxclu + 20 if(n2.eq.nxclu(n)) goto 2 + end + +c------------------------------------------------------------------- +c given two indices n1, n2, actually perform the exchange +c + subroutine exch(n1,n2) + parameter(nx=100000) + dimension x(nx) + common nmax,cost,temp,cmin,rate,x + + h=x(n1) + x(n1)=x(n2) + x(n2)=h + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/randomize.f b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/randomize.f new file mode 100644 index 0000000..0df7779 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/randomize/randomize.f @@ -0,0 +1,127 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c constrained randomization +c author T. Schreiber (1999) +c=========================================================================== + parameter(nx=100000,mx=20) + double precision time + dimension x(nx,mx), y(nx,mx), xx(nx,mx), icol(mx) + character*72 file, fout, comment + common nmax,cost,temp,cmin,rate,x + external rand + data wr/0.9/, nsur/1/ + data iverb/15/ + + call whatido("constrained randomization",iverb) + call what_cost() + call what_cool() + call what_permute() + rr=rand(ican("I",0)/real(2**22)) + nsur=min(999,ican("n",nsur)) + nmax=ican("l",nx) + nexcl=ican("x",0) + mcmax=ican("m",0) + call columns(mc,mx,icol) + if(mcmax.eq.0) mcmax=max(1,mc) + wr=fcan("u",wr) + call opts_cost(mcmax) + call opts_cool() + call opts_permute() + isout=igetout(fout,iverb) + + call nthstring(1,file) + call xreadfile(nmax,mcmax,nx,xx,nexcl,icol,file,iverb) + call cost_transform(nmax,mcmax,nx,xx) + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_rnd") + if(nsur.gt.1) call suffix(fout,"_000") + + do 10 isur=1,nsur + do 20 n=1,nmax + do 20 m=1,mcmax + 20 x(n,m)=xx(n,m) + rate=1 + cost=r1mach(2) + cmin=cost + if(nsur.gt.1) write(fout(index(fout," ")-3:72),'(i3.3)') isur + temp=cool_init() + call cost_init() + call permute_init() + call cost_full(iv_vcost(iverb)) + cmin=cost + time=0 + 1 time=time+1. + call permute(n1,n2) + cmax=cost-temp*log(rand(0.0)) ! maximal acceptable cost + call cost_update(n1,n2,cmax,iaccept,iv_vmatch(iverb)) + tnew=cool(iaccept,iend,iv_cool(iverb)) + if(tnew.ne.temp.or.cost.lt.cmin*wr) then + cc=cost + call cost_full(iv_vcost(iverb)) + if(iv_match(iverb).eq.1) write(istderr(),*) + . "cost function mismatch: ", abs((cc-cost)/cost) + endif + temp=tnew + if(cost.lt.cmin*wr) then + if(iv_cost(iverb).eq.1) write(istderr(),*) + . "after ",real(time)," steps at T=",temp," cost: ",cost + cmin=cost + call cost_inverse(nmax,mcmax,nx,x,y) + write(comment,'(8h# cost: ,g15.5)') cost + call xwritecfile(nmax,mcmax,nx,y,fout,iverb,comment) + endif + if(iend.ne.1) goto 1 + write(comment,'(8h# cost: ,g15.5)') cost + call writecfile(nmax,mcmax,nx,y,fout,iverb,comment) + 10 continue + end + + subroutine usage() +c usage message + + call whatineed("[-n# -u# -I# -o outfile -l# -x# -c# -V# -h]"// + . " [cost opt.] [cooling opt.] [permutation opt.] file") + call popt("n","number of surrogates (1)") + call popt("u","improvement factor before write (0.9)") + call popt("I","seed for random numbers (0)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_rnd(_nnn)") + call pall() + call ptext("Verbosity levels (add what you want):") + call ptext(" 1 = input/output" ) + call ptext(" 2 = current cost if improved") + call ptext(" 4 = cost mismatch") + call ptext(" 8 = temperature etc. at cooling") + call ptext(" 16 = verbose cost if improved") + call ptext(" 32 = verbose cost mismatch") + write(istderr(),'()') + call usage_cost() + write(istderr(),'()') + call usage_cool() + write(istderr(),'()') + call usage_permute() + write(istderr(),'()') + stop + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/rank.f b/binaries/src/disembl/Tisean_3.0.1/source_f/rank.f new file mode 100644 index 0000000..f0358a1 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/rank.f @@ -0,0 +1,153 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c box assisted sorting/ranking utilities +c author T. Schreiber (1998) based on earlier versions +c=========================================================================== + subroutine rank(nmax,x,list) +c rank points in x + parameter(nptr=100000) + dimension x(nmax), list(nmax), jptr(0:nptr) + + call minmax(nmax,x,xmin,xmax) + if(xmin.eq.xmax) then + do 10 n=1,nmax + 10 list(n)=n + return + endif + nl=min(nptr,nmax/2) + sc=(nl-1)/(xmax-xmin) + do 20 i=0,nl + 20 jptr(i)=0 + do 30 n=1,nmax + xn=x(n) + i=int((xn-xmin)*sc) + ip=jptr(i) + if ((ip.eq.0).or.(xn.le.x(ip))) then + jptr(i)=n + else + 1 ipp=ip + ip=list(ip) + if ((ip.gt.0).and.(xn.gt.x(ip))) goto 1 + list(ipp)=n + endif + 30 list(n)=ip + n=0 + do 40 i=0,nl + ip=jptr(i) + 2 if (ip.eq.0) goto 40 + n=n+1 + ipp=ip + ip=list(ip) + list(ipp)=n + goto 2 +40 continue + end + + subroutine indexx(nmax,x,list) +c make index table using rank + dimension x(nmax), list(nmax) + + call rank(nmax,x,list) + call rank2index(nmax,list) + end + + subroutine rank2index(nmax,list) +c converts a list of ranks into an index table (or vice versa) in place + integer list(nmax) + + do 10 n=1,nmax + 10 list(n)=-list(n) + do 20 n=1,nmax + if(list(n).gt.0) goto 20 ! has been put in place already + ib=n + im=-list(n) + 1 it=-list(im) + list(im)=ib + if(it.ne.n) then + ib=im + im=it + goto 1 + else + list(n)=im + endif + 20 continue + end + + subroutine sort(nmax,x,list) +c sort using rank and rank2sort + dimension x(nmax), list(nmax) + + call rank(nmax,x,list) + call rank2sort(nmax,x,list) + end + + subroutine rank2sort(nmax,x,list) +c sort x using list of ranks + dimension x(nmax), list(nmax) + + do 10 n=1,nmax + 10 list(n)=-list(n) + do 20 n=1,nmax + if(list(n).gt.0) goto 20 ! has been put in place already + ib=n + hb=x(n) + 1 it=-list(ib) + list(ib)=it + ht=x(it) + x(it)=hb + if(it.ne.n) then + ib=it + hb=ht + goto 1 + endif + 20 continue + end + + subroutine index2sort(nmax,x,list) +c sort x using list of indices + dimension x(nmax), list(nmax) + + do 10 n=1,nmax + 10 list(n)=-list(n) + do 20 n=1,nmax + if(list(n).gt.0) goto 20 ! has been put in place already + ib=n + h=x(n) + 1 it=-list(ib) + list(ib)=it + if(it.ne.n) then + x(ib)=x(it) + ib=it + goto 1 + else + x(ib)=h + endif + 20 continue + end + + function which(nmax,x,k,list) + dimension x(nmax), list(nmax) + + call indexx(nmax,x,list) + which=x(list(k)) + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/readfile.f b/binaries/src/disembl/Tisean_3.0.1/source_f/readfile.f new file mode 100644 index 0000000..5cc1f13 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/readfile.f @@ -0,0 +1,186 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c +c i/o utilities for TISEAN f-sources +c author T. Schreiber (1998) based on earlier versions +c=========================================================================== + subroutine readfile(nmax,x,nexcl,icol,file,iverb) +c read at most nmax points, return nmax + dimension x(nmax) + character*(*) file + + iv=iv_io(iverb) + if(icol.eq.0) icol=igetcol(file) + if(icol.gt.0.and.iv.ne.0) + . write(istderr(),*) 'reading from column', icol + call infile(file,iunit,iverb) + lc=0 + do 10 n=1,nexcl + lc=lc+1 + 10 read(iunit,*,end=999) + do 20 n=1,nmax + 1 lc=lc+1 + read(iunit,*,err=2,end=999) (dum,i=1,icol-1), x(n) + goto 20 + 2 if(iv.ne.0) write(istderr(),*) "data in line ", lc, " ignored" + goto 1 + 20 continue + if(iv.ne.0) write(istderr(),*) '*** readfile: warning:'// + . ' maybe not the whole file has been used' + 999 nmax=n-1 + if(iunit.ne.istdin()) close(iunit) + if(iv.ne.0) call readreport(nmax,file) + if(icol.gt.0.and.file.ne."-") call putcol(file,icol) + end + + function igetcol(file) + character*(*) file + + igetcol=0 + do 10 i=len(file),1,-1 + 10 if(file(i:i).eq.",") goto 1 + 1 if(i.eq.0) return + read(file(i+1:len(file)),'(i10)',err=999) igetcol + file(i:len(file))=" " + 999 continue + end + + subroutine putcol(file,icol) + character*(*) file + + if(icol.le.9) then + write(file(index(file," "):index(file," ")+1),'(1h,,i1)') icol + else + write(file(index(file," "):index(file," ")+2),'(1h,,i2)') icol + endif + end + + subroutine writecfile(nmax,x,file,iverb,comm) +c write comment and nmax points + dimension x(nmax) + character*(*) file,comm + + call outfile(file,iunit,iverb) + if(comm.ne." ") write(iunit,'(a)') comm + do 10 n=1,nmax + 10 write(iunit,*) x(n) + if(iunit.eq.istdout()) then + write(iunit,*) + write(iunit,*) + else + close(iunit) + endif + if(iv_io(iverb).eq.1) call writereport(nmax,file) + end + + subroutine writefile(nmax,x,file,iverb) +c write nmax points + dimension x(nmax) + character*(*) file + + call writecfile(nmax,x,file,iverb," ") + end + + subroutine infile(file,iunit,iverb) +c open file for read on iunit=ifile(), or iunit=istdin() if "-" + character*(*) file + + if(file.eq."-") then + iunit=istdin() + if(iv_io(iverb).eq.1) write(istderr(),*) "reading from stdin" + return + endif + iunit=ifilein() + open(iunit,file=file,status="old",err=999) + if(iv_io(iverb).eq.1) write(istderr(),'(a,a,a)') + . "opened ",file(1:index(file," ")-1), " for input" + return + 999 write(istderr(),'(a,a)') "Cannot open input file ", + . file(1:index(file," ")-1) + stop + end + + subroutine outfile(file,iunit,iverb) +c open file for write on iunit=ifileout(), or iunit=istdout() if file=" " + character*(*) file + + if(file.eq." ") then + iunit=istdout() + if(iv_io(iverb).eq.1) write(istderr(),*) "writing to stdout" + return + endif + iunit=ifileout() + open(iunit,file=file,status='unknown',err=999) + if(iv_io(iverb).eq.1) write(istderr(),'(a,a,a)') + . "opened ",file(1:index(file," ")-1), " for output" + return + 999 write(istderr(),'(a,a)') "Cannot open output file ", + . file(1:index(file," ")-1) + stop + end + + subroutine suffix(base,suff) +c append stuff after last nonblank character in base + character*(*) base, suff + + base=base(1:index(base," ")-1)//suff + end + + subroutine addsuff(target,base,suff) +c append stuff after last nonblank character in base + character*(*) target,base, suff + + target=base(1:index(base," ")-1)//suff + end + + subroutine readreport(nmax,file) +c report on numbers read + character*(*) file + + if(file.eq."-") then + write(istderr(),'(i10,a)') nmax, ' values read from stdin' + else + write(istderr(),'(i10,a,a)') nmax, ' values read from file: ', + . file(1:index(file," ")-1) + endif + if(nmax.ne.0) return + if(file.eq."-") then + write(istderr(),'(a)') "No input given - aborting." + else + write(istderr(),'(a,a,a)') "Input file ", + . file(1:index(file," ")-1), " empty - aborting." + endif + call usage() + end + + subroutine writereport(nmax,file) +c report on numbers written + character*(*) file + + if(file.eq." ") then + write(istderr(),'(i10,a)') nmax, ' values written to stdout' + else + write(istderr(),'(i10,a,a)') nmax, ' values written to file: ', + . file(1:index(file," ")-1) + endif + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/rms.f b/binaries/src/disembl/Tisean_3.0.1/source_f/rms.f new file mode 100644 index 0000000..eb84228 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/rms.f @@ -0,0 +1,82 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c subtract mean, normalise to unit variance, or +c print mean, standard deviation, and range of series in file(s) +c author T. Schreiber (1998) based on earlier versions +c=========================================================================== + parameter(nx=1000000) + dimension x(nx) + character*72 file, fout + data lmean/0/, lvar/0/ + data iverb/1/ + + call whatido("compute mean/standard deviation, normalise",iverb) + nmaxx=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + if(lopt("a",1).eq.1) lmean=1 + if(lopt("v",1).eq.1) lvar=1 + isout=igetout(fout,iverb) + if(iv_io(iverb).eq.1) write(istderr(),*) + . "mean / standard deviation / smallest / largest" + + do 10 ifi=1,nstrings() + call nthstring(ifi,file) + nmax=nmaxx + call readfile(nmax,x,nexcl,jcol,file,iverb) + if(file.eq."-") file="stdin" + call rms(nmax,x,sc,sd) + call minmax(nmax,x,xmin,xmax) + if(lvar.eq.1.or.lmean.eq.1) then + if(iv_io(iverb).eq.1) write(istderr(),*) + . sc, sd, xmin, xmax, " ", file(1:index(file," ")-1) + if(lvar.eq.1) then + if(isout.eq.1) call addsuff(fout,file,"_v") + call normal1(nmax,x,sc,sd) + else + if(isout.eq.1) call addsuff(fout,file,"_a") + call normal(nmax,x,sc,sd) + endif + call writefile(nmax,x,fout,iverb) + else + write(*,*) + . sc, sd, xmin, xmax, " ", file(1:index(file," ")-1) + endif + 10 continue + end + + subroutine usage() +c usage message + + call whatineed( + . "[-a -v -o outfile -l# -x# -c# -V# -h] file(s)") + call popt("a","subtract average") + call popt("v","subtract mean, normalise to unit variance") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_a (if -a), file_v (if -v)") + call pall() + stop + end + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/Makefile.in b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/Makefile.in new file mode 100644 index 0000000..9e4cea8 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/Makefile.in @@ -0,0 +1,27 @@ +SHELL = /bin/sh + +FC = @FC@ +FFLAGS = @FFLAGS@ +LDFLAGS = @LDFLAGS@ +AR = @AR@ +ARFLAGS = @ARFLAGS@ +RANLIB = @RANLIB@ + +# list of objects to be put in libslac.a + INC = d1mach.o r1mach.o i1mach.o \ + rand.o rgauss.o dqk15.o \ + rs.o tql2.o tqlrat.o tred1.o tred2.o pythag.o \ + rffti1.o rfftf1.o rfftb1.o \ + radf2.o radf3.o radf4.o radf5.o radfg.o \ + radb2.o radb3.o radb4.o radb5.o radbg.o \ + snls1.o fdjac3.o lmpar.o rwupdt.o chkder.o \ + qrfac.o qrsolv.o enorm.o \ + xercnt.o xermsg.o xerhlt.o xersve.o \ + j4save.o xgetua.o xerprn.o fdump.o + +../libsla.a: $(INC) + $(AR) $(ARFLAGS) ../libsla.a $? + $(RANLIB) ../libsla.a + +clean: + -@rm -f *.o *~ #*# diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/chkder.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/chkder.f new file mode 100644 index 0000000..f699bc6 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/chkder.f @@ -0,0 +1,158 @@ +*DECK CHKDER + SUBROUTINE CHKDER (M, N, X, FVEC, FJAC, LDFJAC, XP, FVECP, MODE, + + ERR) +C***BEGIN PROLOGUE CHKDER +C***PURPOSE Check the gradients of M nonlinear functions in N +C variables, evaluated at a point X, for consistency +C with the functions themselves. +C***LIBRARY SLATEC +C***CATEGORY F3, G4C +C***TYPE SINGLE PRECISION (CHKDER-S, DCKDER-D) +C***KEYWORDS GRADIENTS, JACOBIAN, MINPACK, NONLINEAR +C***AUTHOR Hiebert, K. L. (SNLA) +C***DESCRIPTION +C +C This subroutine is a companion routine to SNLS1,SNLS1E,SNSQ,and +C SNSQE which may be used to check the calculation of the Jacobian. +C +C SUBROUTINE CHKDER +C +C This subroutine checks the gradients of M nonlinear functions +C in N variables, evaluated at a point X, for consistency with +C the functions themselves. The user must call CKDER twice, +C first with MODE = 1 and then with MODE = 2. +C +C MODE = 1. On input, X must contain the point of evaluation. +C On output, XP is set to a neighboring point. +C +C MODE = 2. On input, FVEC must contain the functions and the +C rows of FJAC must contain the gradients +C of the respective functions each evaluated +C at X, and FVECP must contain the functions +C evaluated at XP. +C On output, ERR contains measures of correctness of +C the respective gradients. +C +C The subroutine does not perform reliably if cancellation or +C rounding errors cause a severe loss of significance in the +C evaluation of a function. Therefore, none of the components +C of X should be unusually small (in particular, zero) or any +C other value which may cause loss of significance. +C +C The SUBROUTINE statement is +C +C SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) +C +C where +C +C M is a positive integer input variable set to the number +C of functions. +C +C N is a positive integer input variable set to the number +C of variables. +C +C X is an input array of length N. +C +C FVEC is an array of length M. On input when MODE = 2, +C FVEC must contain the functions evaluated at X. +C +C FJAC is an M by N array. On input when MODE = 2, +C the rows of FJAC must contain the gradients of +C the respective functions evaluated at X. +C +C LDFJAC is a positive integer input parameter not less than M +C which specifies the leading dimension of the array FJAC. +C +C XP is an array of length N. On output when MODE = 1, +C XP is set to a neighboring point of X. +C +C FVECP is an array of length M. On input when MODE = 2, +C FVECP must contain the functions evaluated at XP. +C +C MODE is an integer input variable set to 1 on the first call +C and 2 on the second. Other values of MODE are equivalent +C to MODE = 1. +C +C ERR is an array of length M. On output when MODE = 2, +C ERR contains measures of correctness of the respective +C gradients. If there is no severe loss of significance, +C then if ERR(I) is 1.0 the I-th gradient is correct, +C while if ERR(I) is 0.0 the I-th gradient is incorrect. +C For values of ERR between 0.0 and 1.0, the categorization +C is less certain. In general, a value of ERR(I) greater +C than 0.5 indicates that the I-th gradient is probably +C correct, while a value of ERR(I) less than 0.5 indicates +C that the I-th gradient is probably incorrect. +C +C***REFERENCES M. J. D. Powell, A hybrid method for nonlinear equa- +C tions. In Numerical Methods for Nonlinear Algebraic +C Equations, P. Rabinowitz, Editor. Gordon and Breach, +C 1988. +C***ROUTINES CALLED R1MACH +C***REVISION HISTORY (YYMMDD) +C 800301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE CHKDER + INTEGER M,N,LDFJAC,MODE + REAL X(*),FVEC(*),FJAC(LDFJAC,*),XP(*),FVECP(*),ERR(*) + INTEGER I,J + REAL EPS,EPSF,EPSLOG,EPSMCH,FACTOR,ONE,TEMP,ZERO + REAL R1MACH + SAVE FACTOR, ONE, ZERO +C + DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/ +C***FIRST EXECUTABLE STATEMENT CHKDER + EPSMCH = R1MACH(4) +C + EPS = SQRT(EPSMCH) +C + IF (MODE .EQ. 2) GO TO 20 +C +C MODE = 1. +C + DO 10 J = 1, N + TEMP = EPS*ABS(X(J)) + IF (TEMP .EQ. ZERO) TEMP = EPS + XP(J) = X(J) + TEMP + 10 CONTINUE + GO TO 70 + 20 CONTINUE +C +C MODE = 2. +C + EPSF = FACTOR*EPSMCH + EPSLOG = LOG10(EPS) + DO 30 I = 1, M + ERR(I) = ZERO + 30 CONTINUE + DO 50 J = 1, N + TEMP = ABS(X(J)) + IF (TEMP .EQ. ZERO) TEMP = ONE + DO 40 I = 1, M + ERR(I) = ERR(I) + TEMP*FJAC(I,J) + 40 CONTINUE + 50 CONTINUE + DO 60 I = 1, M + TEMP = ONE + IF (FVEC(I) .NE. ZERO .AND. FVECP(I) .NE. ZERO + 1 .AND. ABS(FVECP(I)-FVEC(I)) .GE. EPSF*ABS(FVEC(I))) + 2 TEMP = EPS*ABS((FVECP(I)-FVEC(I))/EPS-ERR(I)) + 3 /(ABS(FVEC(I)) + ABS(FVECP(I))) + ERR(I) = ONE + IF (TEMP .GT. EPSMCH .AND. TEMP .LT. EPS) + 1 ERR(I) = (LOG10(TEMP) - EPSLOG)/EPSLOG + IF (TEMP .GE. EPS) ERR(I) = ZERO + 60 CONTINUE + 70 CONTINUE +C + RETURN +C +C LAST CARD OF SUBROUTINE CHKDER. +C + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/d1mach.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/d1mach.f new file mode 100644 index 0000000..de4ac08 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/d1mach.f @@ -0,0 +1,19 @@ + DOUBLE PRECISION FUNCTION D1MACH (I) +c this is not the original one from slatec + double precision const(5) +c small: + DATA const(1) / 2.23D-308 / +c large: + DATA const(2) / 1.79D+308 / +c diff: + DATA const(3) / 1.11D-16 / + DATA const(4) / 2.22D-16 / +c log10: + DATA const(5) / 0.301029995663981195D0 / + +C***FIRST EXECUTABLE STATEMENT D1MACH +C + D1MACH = const(I) + RETURN +C + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/dqk15.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/dqk15.f new file mode 100644 index 0000000..a764ccd --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/dqk15.f @@ -0,0 +1,185 @@ +*DECK DQK15 + SUBROUTINE DQK15 (F, A, B, RESULT, ABSERR, RESABS, RESASC) +C***BEGIN PROLOGUE DQK15 +C***PURPOSE To compute I = Integral of F over (A,B), with error +C estimate +C J = integral of ABS(F) over (A,B) +C***LIBRARY SLATEC (QUADPACK) +C***CATEGORY H2A1A2 +C***TYPE DOUBLE PRECISION (QK15-S, DQK15-D) +C***KEYWORDS 15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE +C***AUTHOR Piessens, Robert +C Applied Mathematics and Programming Division +C K. U. Leuven +C de Doncker, Elise +C Applied Mathematics and Programming Division +C K. U. Leuven +C***DESCRIPTION +C +C Integration rules +C Standard fortran subroutine +C Double precision version +C +C PARAMETERS +C ON ENTRY +C F - Double precision +C Function subprogram defining the integrand +C FUNCTION F(X). The actual name for F needs to be +C Declared E X T E R N A L in the calling program. +C +C A - Double precision +C Lower limit of integration +C +C B - Double precision +C Upper limit of integration +C +C ON RETURN +C RESULT - Double precision +C Approximation to the integral I +C Result is computed by applying the 15-POINT +C KRONROD RULE (RESK) obtained by optimal addition +C of abscissae to the 7-POINT GAUSS RULE(RESG). +C +C ABSERR - Double precision +C Estimate of the modulus of the absolute error, +C which should not exceed ABS(I-RESULT) +C +C RESABS - Double precision +C Approximation to the integral J +C +C RESASC - Double precision +C Approximation to the integral of ABS(F-I/(B-A)) +C over (A,B) +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH +C***REVISION HISTORY (YYMMDD) +C 800101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE DQK15 +C + DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH, + 1 D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, + 2 RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK + INTEGER J,JTW,JTWM1 + EXTERNAL F +C + DIMENSION FV1(7),FV2(7),WG(4),WGK(8),XGK(8) +C +C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). +C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR +C CORRESPONDING WEIGHTS ARE GIVEN. +C +C XGK - ABSCISSAE OF THE 15-POINT KRONROD RULE +C XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT +C GAUSS RULE +C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY +C ADDED TO THE 7-POINT GAUSS RULE +C +C WGK - WEIGHTS OF THE 15-POINT KRONROD RULE +C +C WG - WEIGHTS OF THE 7-POINT GAUSS RULE +C +C +C GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS +C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, +C BELL LABS, NOV. 1981. +C + SAVE WG, XGK, WGK + DATA WG ( 1) / 0.1294849661 6886969327 0611432679 082 D0 / + DATA WG ( 2) / 0.2797053914 8927666790 1467771423 780 D0 / + DATA WG ( 3) / 0.3818300505 0511894495 0369775488 975 D0 / + DATA WG ( 4) / 0.4179591836 7346938775 5102040816 327 D0 / +C + DATA XGK ( 1) / 0.9914553711 2081263920 6854697526 329 D0 / + DATA XGK ( 2) / 0.9491079123 4275852452 6189684047 851 D0 / + DATA XGK ( 3) / 0.8648644233 5976907278 9712788640 926 D0 / + DATA XGK ( 4) / 0.7415311855 9939443986 3864773280 788 D0 / + DATA XGK ( 5) / 0.5860872354 6769113029 4144838258 730 D0 / + DATA XGK ( 6) / 0.4058451513 7739716690 6606412076 961 D0 / + DATA XGK ( 7) / 0.2077849550 0789846760 0689403773 245 D0 / + DATA XGK ( 8) / 0.0000000000 0000000000 0000000000 000 D0 / +C + DATA WGK ( 1) / 0.0229353220 1052922496 3732008058 970 D0 / + DATA WGK ( 2) / 0.0630920926 2997855329 0700663189 204 D0 / + DATA WGK ( 3) / 0.1047900103 2225018383 9876322541 518 D0 / + DATA WGK ( 4) / 0.1406532597 1552591874 5189590510 238 D0 / + DATA WGK ( 5) / 0.1690047266 3926790282 6583426598 550 D0 / + DATA WGK ( 6) / 0.1903505780 6478540991 3256402421 014 D0 / + DATA WGK ( 7) / 0.2044329400 7529889241 4161999234 649 D0 / + DATA WGK ( 8) / 0.2094821410 8472782801 2999174891 714 D0 / +C +C +C LIST OF MAJOR VARIABLES +C ----------------------- +C +C CENTR - MID POINT OF THE INTERVAL +C HLGTH - HALF-LENGTH OF THE INTERVAL +C ABSC - ABSCISSA +C FVAL* - FUNCTION VALUE +C RESG - RESULT OF THE 7-POINT GAUSS FORMULA +C RESK - RESULT OF THE 15-POINT KRONROD FORMULA +C RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), +C I.E. TO I/(B-A) +C +C MACHINE DEPENDENT CONSTANTS +C --------------------------- +C +C EPMACH IS THE LARGEST RELATIVE SPACING. +C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. +C +C***FIRST EXECUTABLE STATEMENT DQK15 + EPMACH = D1MACH(4) + UFLOW = D1MACH(1) +C + CENTR = 0.5D+00*(A+B) + HLGTH = 0.5D+00*(B-A) + DHLGTH = ABS(HLGTH) +C +C COMPUTE THE 15-POINT KRONROD APPROXIMATION TO +C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. +C + FC = F(CENTR) + RESG = FC*WG(4) + RESK = FC*WGK(8) + RESABS = ABS(RESK) + DO 10 J=1,3 + JTW = J*2 + ABSC = HLGTH*XGK(JTW) + FVAL1 = F(CENTR-ABSC) + FVAL2 = F(CENTR+ABSC) + FV1(JTW) = FVAL1 + FV2(JTW) = FVAL2 + FSUM = FVAL1+FVAL2 + RESG = RESG+WG(J)*FSUM + RESK = RESK+WGK(JTW)*FSUM + RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) + 10 CONTINUE + DO 15 J = 1,4 + JTWM1 = J*2-1 + ABSC = HLGTH*XGK(JTWM1) + FVAL1 = F(CENTR-ABSC) + FVAL2 = F(CENTR+ABSC) + FV1(JTWM1) = FVAL1 + FV2(JTWM1) = FVAL2 + FSUM = FVAL1+FVAL2 + RESK = RESK+WGK(JTWM1)*FSUM + RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) + 15 CONTINUE + RESKH = RESK*0.5D+00 + RESASC = WGK(8)*ABS(FC-RESKH) + DO 20 J=1,7 + RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) + 20 CONTINUE + RESULT = RESK*HLGTH + RESABS = RESABS*DHLGTH + RESASC = RESASC*DHLGTH + ABSERR = ABS((RESK-RESG)*HLGTH) + IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00) + 1 ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) + IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX + 1 ((EPMACH*0.5D+02)*RESABS,ABSERR) + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/enorm.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/enorm.f new file mode 100644 index 0000000..7eeda1e --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/enorm.f @@ -0,0 +1,117 @@ +*DECK ENORM + REAL FUNCTION ENORM (N, X) +C***BEGIN PROLOGUE ENORM +C***SUBSIDIARY +C***PURPOSE Subsidiary to SNLS1, SNLS1E, SNSQ and SNSQE +C***LIBRARY SLATEC +C***TYPE SINGLE PRECISION (ENORM-S, DENORM-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C Given an N-vector X, this function calculates the +C Euclidean norm of X. +C +C The Euclidean norm is computed by accumulating the sum of +C squares in three different sums. The sums of squares for the +C small and large components are scaled so that no overflows +C occur. Non-destructive underflows are permitted. Underflows +C and overflows do not occur in the computation of the unscaled +C sum of squares for the intermediate components. +C The definitions of small, intermediate and large components +C depend on two constants, RDWARF and RGIANT. The main +C restrictions on these constants are that RDWARF**2 not +C underflow and RGIANT**2 not overflow. The constants +C given here are suitable for every known computer. +C +C The function statement is +C +C REAL FUNCTION ENORM(N,X) +C +C where +C +C N is a positive integer input variable. +C +C X is an input array of length N. +C +C***SEE ALSO SNLS1, SNLS1E, SNSQ, SNSQE +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 800301 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 900328 Added TYPE section. (WRB) +C***END PROLOGUE ENORM + INTEGER N + REAL X(*) + INTEGER I + REAL AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS,X1MAX,X3MAX, + 1 ZERO + SAVE ONE, ZERO, RDWARF, RGIANT + DATA ONE,ZERO,RDWARF,RGIANT /1.0E0,0.0E0,3.834E-20,1.304E19/ +C***FIRST EXECUTABLE STATEMENT ENORM + S1 = ZERO + S2 = ZERO + S3 = ZERO + X1MAX = ZERO + X3MAX = ZERO + FLOATN = N + AGIANT = RGIANT/FLOATN + DO 90 I = 1, N + XABS = ABS(X(I)) + IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70 + IF (XABS .LE. RDWARF) GO TO 30 +C +C SUM FOR LARGE COMPONENTS. +C + IF (XABS .LE. X1MAX) GO TO 10 + S1 = ONE + S1*(X1MAX/XABS)**2 + X1MAX = XABS + GO TO 20 + 10 CONTINUE + S1 = S1 + (XABS/X1MAX)**2 + 20 CONTINUE + GO TO 60 + 30 CONTINUE +C +C SUM FOR SMALL COMPONENTS. +C + IF (XABS .LE. X3MAX) GO TO 40 + S3 = ONE + S3*(X3MAX/XABS)**2 + X3MAX = XABS + GO TO 50 + 40 CONTINUE + IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2 + 50 CONTINUE + 60 CONTINUE + GO TO 80 + 70 CONTINUE +C +C SUM FOR INTERMEDIATE COMPONENTS. +C + S2 = S2 + XABS**2 + 80 CONTINUE + 90 CONTINUE +C +C CALCULATION OF NORM. +C + IF (S1 .EQ. ZERO) GO TO 100 + ENORM = X1MAX*SQRT(S1+(S2/X1MAX)/X1MAX) + GO TO 130 + 100 CONTINUE + IF (S2 .EQ. ZERO) GO TO 110 + IF (S2 .GE. X3MAX) + 1 ENORM = SQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3))) + IF (S2 .LT. X3MAX) + 1 ENORM = SQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3))) + GO TO 120 + 110 CONTINUE + ENORM = X3MAX*SQRT(S3) + 120 CONTINUE + 130 CONTINUE + RETURN +C +C LAST CARD OF FUNCTION ENORM. +C + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/fdjac3.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/fdjac3.f new file mode 100644 index 0000000..8ca42c4 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/fdjac3.f @@ -0,0 +1,114 @@ +*DECK FDJAC3 + SUBROUTINE FDJAC3 (FCN, M, N, X, FVEC, FJAC, LDFJAC, IFLAG, + + EPSFCN, WA) +C***BEGIN PROLOGUE FDJAC3 +C***SUBSIDIARY +C***PURPOSE Subsidiary to SNLS1 and SNLS1E +C***LIBRARY SLATEC +C***TYPE SINGLE PRECISION (FDJAC3-S, DFDJC3-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C This subroutine computes a forward-difference approximation +C to the M by N Jacobian matrix associated with a specified +C problem of M functions in N variables. +C +C The subroutine statement is +C +C SUBROUTINE FDJAC3(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) +C +C where +C +C FCN is the name of the user-supplied subroutine which +C calculates the functions. FCN must be declared +C in an external statement in the user calling +C program, and should be written as follows. +C +C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) +C INTEGER LDFJAC,M,N,IFLAG +C REAL X(N),FVEC(M),FJAC(LDFJAC,N) +C ---------- +C When IFLAG.EQ.1 calculate the functions at X and +C return this vector in FVEC. +C ---------- +C RETURN +C END +C +C The value of IFLAG should not be changed by FCN unless +C the user wants to terminate execution of FDJAC3. +C In this case set IFLAG to a negative integer. +C +C M is a positive integer input variable set to the number +C of functions. +C +C N is a positive integer input variable set to the number +C of variables. N must not exceed M. +C +C X is an input array of length N. +C +C FVEC is an input array of length M which must contain the +C functions evaluated at X. +C +C FJAC is an output M by N array which contains the +C approximation to the Jacobian matrix evaluated at X. +C +C LDFJAC is a positive integer input variable not less than M +C which specifies the leading dimension of the array FJAC. +C +C IFLAG is an integer variable which can be used to terminate +C THE EXECUTION OF FDJAC3. See description of FCN. +C +C EPSFCN is an input variable used in determining a suitable +C step length for the forward-difference approximation. This +C approximation assumes that the relative errors in the +C functions are of the order of EPSFCN. If EPSFCN is less +C than the machine precision, it is assumed that the relative +C errors in the functions are of the order of the machine +C precision. +C +C WA is a work array of length M. +C +C***SEE ALSO SNLS1, SNLS1E +C***ROUTINES CALLED R1MACH +C***REVISION HISTORY (YYMMDD) +C 800301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 900328 Added TYPE section. (WRB) +C***END PROLOGUE FDJAC3 + INTEGER M,N,LDFJAC,IFLAG + REAL EPSFCN + REAL X(*),FVEC(*),FJAC(LDFJAC,*),WA(*) + INTEGER I,J + REAL EPS,EPSMCH,H,TEMP,ZERO + REAL R1MACH + SAVE ZERO + DATA ZERO /0.0E0/ +C***FIRST EXECUTABLE STATEMENT FDJAC3 + EPSMCH = R1MACH(4) +C + EPS = SQRT(MAX(EPSFCN,EPSMCH)) +C SET IFLAG=1 TO INDICATE THAT FUNCTION VALUES +C ARE TO BE RETURNED BY FCN. + IFLAG = 1 + DO 20 J = 1, N + TEMP = X(J) + H = EPS*ABS(TEMP) + IF (H .EQ. ZERO) H = EPS + X(J) = TEMP + H + CALL FCN(IFLAG,M,N,X,WA,FJAC,LDFJAC) + IF (IFLAG .LT. 0) GO TO 30 + X(J) = TEMP + DO 10 I = 1, M + FJAC(I,J) = (WA(I) - FVEC(I))/H + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE FDJAC3. +C + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/fdump.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/fdump.f new file mode 100644 index 0000000..1f44a57 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/fdump.f @@ -0,0 +1,31 @@ +*DECK FDUMP + SUBROUTINE FDUMP +C***BEGIN PROLOGUE FDUMP +C***PURPOSE Symbolic dump (should be locally written). +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3 +C***TYPE ALL (FDUMP-A) +C***KEYWORDS ERROR, XERMSG +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C ***Note*** Machine Dependent Routine +C FDUMP is intended to be replaced by a locally written +C version which produces a symbolic dump. Failing this, +C it should be replaced by a version which prints the +C subprogram nesting list. Note that this dump must be +C printed on each of up to five files, as indicated by the +C XGETUA routine. See XSETUA and XGETUA for details. +C +C Written by Ron Jones, with SLATEC Common Math Library Subcommittee +C +C***REFERENCES (NONE) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE FDUMP +C***FIRST EXECUTABLE STATEMENT FDUMP + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/i1mach.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/i1mach.f new file mode 100644 index 0000000..5442678 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/i1mach.f @@ -0,0 +1,142 @@ +*DECK I1MACH + INTEGER FUNCTION I1MACH (I) +c---------------------------------------------------------------------- +c +c this is not quit the original one from slatec +c unit numbers for input/output/error are provided by calls to routines +c from istdio.f change them there if needed!!! +c +c the other constants are not currently used by TISEAN and not checked +c for any particular platform +c +c---------------------------------------------------------------------- +C***BEGIN PROLOGUE I1MACH +C***PURPOSE Return integer machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE INTEGER (I1MACH-I) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C I1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument and can be referenced as follows: +C +C K = I1MACH(I) +C +C where I=1,...,16. The (output) value of K above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +C I/O unit numbers: +C I1MACH( 1) = the standard input unit. +C I1MACH( 2) = the standard output unit. +C I1MACH( 3) = the standard punch unit. +C I1MACH( 4) = the standard error message unit. +C +C Words: +C I1MACH( 5) = the number of bits per integer storage unit. +C I1MACH( 6) = the number of characters per integer storage unit. +C +C Integers: +C assume integers are represented in the S-digit, base-A form +C +C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) +C +C where 0 .LE. X(I) .LT. A for I=0,...,S-1. +C I1MACH( 7) = A, the base. +C I1MACH( 8) = S, the number of base-A digits. +C I1MACH( 9) = A**S - 1, the largest magnitude. +C +C Floating-Point Numbers: +C Assume floating-point numbers are represented in the T-digit, +C base-B form +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, +C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. +C I1MACH(10) = B, the base. +C +C Single-Precision: +C I1MACH(11) = T, the number of base-B digits. +C I1MACH(12) = EMIN, the smallest exponent E. +C I1MACH(13) = EMAX, the largest exponent E. +C +C Double-Precision: +C I1MACH(14) = T, the number of base-B digits. +C I1MACH(15) = EMIN, the smallest exponent E. +C I1MACH(16) = EMAX, the largest exponent E. +C +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 891012 Added VAX G-floating constants. (WRB) +C 891012 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. +C (RWC) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added Convex -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler +C options. (DWL, RWC and WRB). +C***END PROLOGUE I1MACH +C + INTEGER IMACH(16),OUTPUT + SAVE IMACH + EQUIVALENCE (IMACH(4),OUTPUT) + + DATA IMACH( 1) / 5 / + DATA IMACH( 2) / 6 / + DATA IMACH( 3) / 0 / + DATA IMACH( 4) / 0 / + DATA IMACH( 5) / 32 / + DATA IMACH( 6) / 4 / + DATA IMACH( 7) / 2 / + DATA IMACH( 8) / 31 / + DATA IMACH( 9) / 2147483647 / + DATA IMACH(10) / 2 / + DATA IMACH(11) / 24 / + DATA IMACH(12) / -125 / + DATA IMACH(13) / 127 / + DATA IMACH(14) / 53 / + DATA IMACH(15) / -1021 / + DATA IMACH(16) / 1023 / + +C***FIRST EXECUTABLE STATEMENT I1MACH + IMACH(1)=ISTDIN() + IMACH(2)=ISTDOUT() + IMACH(3)=ISTDERR() + IMACH(4)=ISTDERR() + + IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 +C + I1MACH = IMACH(I) + RETURN +C + 10 CONTINUE + WRITE (UNIT = OUTPUT, FMT = 9000) + 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') +C +C CALL FDUMP +C + STOP + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/j4save.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/j4save.f new file mode 100644 index 0000000..6ec799b --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/j4save.f @@ -0,0 +1,65 @@ +*DECK J4SAVE + FUNCTION J4SAVE (IWHICH, IVALUE, ISET) +C***BEGIN PROLOGUE J4SAVE +C***SUBSIDIARY +C***PURPOSE Save or recall global variables needed by error +C handling routines. +C***LIBRARY SLATEC (XERROR) +C***TYPE INTEGER (J4SAVE-I) +C***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C J4SAVE saves and recalls several global variables needed +C by the library error handling routines. +C +C Description of Parameters +C --Input-- +C IWHICH - Index of item desired. +C = 1 Refers to current error number. +C = 2 Refers to current error control flag. +C = 3 Refers to current unit number to which error +C messages are to be sent. (0 means use standard.) +C = 4 Refers to the maximum number of times any +C message is to be printed (as set by XERMAX). +C = 5 Refers to the total number of units to which +C each error message is to be written. +C = 6 Refers to the 2nd unit for error messages +C = 7 Refers to the 3rd unit for error messages +C = 8 Refers to the 4th unit for error messages +C = 9 Refers to the 5th unit for error messages +C IVALUE - The value to be set for the IWHICH-th parameter, +C if ISET is .TRUE. . +C ISET - If ISET=.TRUE., the IWHICH-th parameter will BE +C given the value, IVALUE. If ISET=.FALSE., the +C IWHICH-th parameter will be unchanged, and IVALUE +C is a dummy parameter. +C --Output-- +C The (old) value of the IWHICH-th parameter will be returned +C in the function value, J4SAVE. +C +C***SEE ALSO XERMSG +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900205 Minor modifications to prologue. (WRB) +C 900402 Added TYPE section. (WRB) +C 910411 Added KEYWORDS section. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE J4SAVE + LOGICAL ISET + INTEGER IPARAM(9) + SAVE IPARAM + DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/ + DATA IPARAM(5)/1/ + DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ +C***FIRST EXECUTABLE STATEMENT J4SAVE + J4SAVE = IPARAM(IWHICH) + IF (ISET) IPARAM(IWHICH) = IVALUE + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/lmpar.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/lmpar.f new file mode 100644 index 0000000..b81e4e9 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/lmpar.f @@ -0,0 +1,267 @@ +*DECK LMPAR + SUBROUTINE LMPAR (N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, X, + + SIGMA, WA1, WA2) +C***BEGIN PROLOGUE LMPAR +C***SUBSIDIARY +C***PURPOSE Subsidiary to SNLS1 and SNLS1E +C***LIBRARY SLATEC +C***TYPE SINGLE PRECISION (LMPAR-S, DMPAR-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C Given an M by N matrix A, an N by N nonsingular DIAGONAL +C matrix D, an M-vector B, and a positive number DELTA, +C the problem is to determine a value for the parameter +C PAR such that if X solves the system +C +C A*X = B , SQRT(PAR)*D*X = 0 , +C +C in the least squares sense, and DXNORM is the Euclidean +C norm of D*X, then either PAR is zero and +C +C (DXNORM-DELTA) .LE. 0.1*DELTA , +C +C or PAR is positive and +C +C ABS(DXNORM-DELTA) .LE. 0.1*DELTA . +C +C This subroutine completes the solution of the problem +C if it is provided with the necessary information from the +C QR factorization, with column pivoting, of A. That is, if +C A*P = Q*R, where P is a permutation matrix, Q has orthogonal +C columns, and R is an upper triangular matrix with diagonal +C elements of nonincreasing magnitude, then LMPAR expects +C the full upper triangle of R, the permutation matrix P, +C and the first N components of (Q TRANSPOSE)*B. On output +C LMPAR also provides an upper triangular matrix S such that +C +C T T T +C P *(A *A + PAR*D*D)*P = S *S . +C +C S is employed within LMPAR and may be of separate interest. +C +C Only a few iterations are generally needed for convergence +C of the algorithm. If, however, the limit of 10 iterations +C is reached, then the output PAR will contain the best +C value obtained so far. +C +C The subroutine statement is +C +C SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SIGMA, +C WA1,WA2) +C +C where +C +C N is a positive integer input variable set to the order of R. +C +C R is an N by N array. On input the full upper triangle +C must contain the full upper triangle of the matrix R. +C On output the full upper triangle is unaltered, and the +C strict lower triangle contains the strict upper triangle +C (transposed) of the upper triangular matrix S. +C +C LDR is a positive integer input variable not less than N +C which specifies the leading dimension of the array R. +C +C IPVT is an integer input array of length N which defines the +C permutation matrix P such that A*P = Q*R. Column J of P +C is column IPVT(J) of the identity matrix. +C +C DIAG is an input array of length N which must contain the +C diagonal elements of the matrix D. +C +C QTB is an input array of length N which must contain the first +C N elements of the vector (Q TRANSPOSE)*B. +C +C DELTA is a positive input variable which specifies an upper +C bound on the Euclidean norm of D*X. +C +C PAR is a nonnegative variable. On input PAR contains an +C initial estimate of the Levenberg-Marquardt parameter. +C On output PAR contains the final estimate. +C +C X is an output array of length N which contains the least +C squares solution of the system A*X = B, SQRT(PAR)*D*X = 0, +C for the output PAR. +C +C SIGMA is an output array of length N which contains the +C diagonal elements of the upper triangular matrix S. +C +C WA1 and WA2 are work arrays of length N. +C +C***SEE ALSO SNLS1, SNLS1E +C***ROUTINES CALLED ENORM, QRSOLV, R1MACH +C***REVISION HISTORY (YYMMDD) +C 800301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 900328 Added TYPE section. (WRB) +C***END PROLOGUE LMPAR + INTEGER N,LDR + INTEGER IPVT(*) + REAL DELTA,PAR + REAL R(LDR,*),DIAG(*),QTB(*),X(*),SIGMA(*),WA1(*),WA2(*) + INTEGER I,ITER,J,JM1,JP1,K,L,NSING + REAL DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001,SUM,TEMP,ZERO + REAL R1MACH,ENORM + SAVE P1, P001, ZERO + DATA P1,P001,ZERO /1.0E-1,1.0E-3,0.0E0/ +C***FIRST EXECUTABLE STATEMENT LMPAR + DWARF = R1MACH(1) +C +C COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE +C JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION. +C + NSING = N + DO 10 J = 1, N + WA1(J) = QTB(J) + IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 + IF (NSING .LT. N) WA1(J) = ZERO + 10 CONTINUE + IF (NSING .LT. 1) GO TO 50 + DO 40 K = 1, NSING + J = NSING - K + 1 + WA1(J) = WA1(J)/R(J,J) + TEMP = WA1(J) + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 30 + DO 20 I = 1, JM1 + WA1(I) = WA1(I) - R(I,J)*TEMP + 20 CONTINUE + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + DO 60 J = 1, N + L = IPVT(J) + X(L) = WA1(J) + 60 CONTINUE +C +C INITIALIZE THE ITERATION COUNTER. +C EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST +C FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION. +C + ITER = 0 + DO 70 J = 1, N + WA2(J) = DIAG(J)*X(J) + 70 CONTINUE + DXNORM = ENORM(N,WA2) + FP = DXNORM - DELTA + IF (FP .LE. P1*DELTA) GO TO 220 +C +C IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON +C STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF +C THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO. +C + PARL = ZERO + IF (NSING .LT. N) GO TO 120 + DO 80 J = 1, N + L = IPVT(J) + WA1(J) = DIAG(L)*(WA2(L)/DXNORM) + 80 CONTINUE + DO 110 J = 1, N + SUM = ZERO + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 100 + DO 90 I = 1, JM1 + SUM = SUM + R(I,J)*WA1(I) + 90 CONTINUE + 100 CONTINUE + WA1(J) = (WA1(J) - SUM)/R(J,J) + 110 CONTINUE + TEMP = ENORM(N,WA1) + PARL = ((FP/DELTA)/TEMP)/TEMP + 120 CONTINUE +C +C CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION. +C + DO 140 J = 1, N + SUM = ZERO + DO 130 I = 1, J + SUM = SUM + R(I,J)*QTB(I) + 130 CONTINUE + L = IPVT(J) + WA1(J) = SUM/DIAG(L) + 140 CONTINUE + GNORM = ENORM(N,WA1) + PARU = GNORM/DELTA + IF (PARU .EQ. ZERO) PARU = DWARF/MIN(DELTA,P1) +C +C IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU), +C SET PAR TO THE CLOSER ENDPOINT. +C + PAR = MAX(PAR,PARL) + PAR = MIN(PAR,PARU) + IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM +C +C BEGINNING OF AN ITERATION. +C + 150 CONTINUE + ITER = ITER + 1 +C +C EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR. +C + IF (PAR .EQ. ZERO) PAR = MAX(DWARF,P001*PARU) + TEMP = SQRT(PAR) + DO 160 J = 1, N + WA1(J) = TEMP*DIAG(J) + 160 CONTINUE + CALL QRSOLV(N,R,LDR,IPVT,WA1,QTB,X,SIGMA,WA2) + DO 170 J = 1, N + WA2(J) = DIAG(J)*X(J) + 170 CONTINUE + DXNORM = ENORM(N,WA2) + TEMP = FP + FP = DXNORM - DELTA +C +C IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE +C OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL +C IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10. +C + IF (ABS(FP) .LE. P1*DELTA + 1 .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP + 2 .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220 +C +C COMPUTE THE NEWTON CORRECTION. +C + DO 180 J = 1, N + L = IPVT(J) + WA1(J) = DIAG(L)*(WA2(L)/DXNORM) + 180 CONTINUE + DO 210 J = 1, N + WA1(J) = WA1(J)/SIGMA(J) + TEMP = WA1(J) + JP1 = J + 1 + IF (N .LT. JP1) GO TO 200 + DO 190 I = JP1, N + WA1(I) = WA1(I) - R(I,J)*TEMP + 190 CONTINUE + 200 CONTINUE + 210 CONTINUE + TEMP = ENORM(N,WA1) + PARC = ((FP/DELTA)/TEMP)/TEMP +C +C DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU. +C + IF (FP .GT. ZERO) PARL = MAX(PARL,PAR) + IF (FP .LT. ZERO) PARU = MIN(PARU,PAR) +C +C COMPUTE AN IMPROVED ESTIMATE FOR PAR. +C + PAR = MAX(PARL,PAR+PARC) +C +C END OF AN ITERATION. +C + GO TO 150 + 220 CONTINUE +C +C TERMINATION. +C + IF (ITER .EQ. 0) PAR = ZERO + RETURN +C +C LAST CARD OF SUBROUTINE LMPAR. +C + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/pythag.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/pythag.f new file mode 100644 index 0000000..dc3ef31 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/pythag.f @@ -0,0 +1,39 @@ +*DECK PYTHAG + REAL FUNCTION PYTHAG (A, B) +C***BEGIN PROLOGUE PYTHAG +C***SUBSIDIARY +C***PURPOSE Compute the complex square root of a complex number without +C destructive overflow or underflow. +C***LIBRARY SLATEC +C***TYPE SINGLE PRECISION (PYTHAG-S) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C Finds sqrt(A**2+B**2) without overflow or destructive underflow +C +C***SEE ALSO EISDOC +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 811101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900402 Added TYPE section. (WRB) +C***END PROLOGUE PYTHAG + REAL A,B +C + REAL P,Q,R,S,T +C***FIRST EXECUTABLE STATEMENT PYTHAG + P = MAX(ABS(A),ABS(B)) + Q = MIN(ABS(A),ABS(B)) + IF (Q .EQ. 0.0E0) GO TO 20 + 10 CONTINUE + R = (Q/P)**2 + T = 4.0E0 + R + IF (T .EQ. 4.0E0) GO TO 20 + S = R/T + P = P + 2.0E0*P*S + Q = Q*S + GO TO 10 + 20 PYTHAG = P + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/qrfac.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/qrfac.f new file mode 100644 index 0000000..296d538 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/qrfac.f @@ -0,0 +1,170 @@ +*DECK QRFAC + SUBROUTINE QRFAC (M, N, A, LDA, PIVOT, IPVT, LIPVT, SIGMA, ACNORM, + + WA) +C***BEGIN PROLOGUE QRFAC +C***SUBSIDIARY +C***PURPOSE Subsidiary to SNLS1, SNLS1E, SNSQ and SNSQE +C***LIBRARY SLATEC +C***TYPE SINGLE PRECISION (QRFAC-S, DQRFAC-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C This subroutine uses Householder transformations with column +C pivoting (optional) to compute a QR factorization of the +C M by N matrix A. That is, QRFAC determines an orthogonal +C matrix Q, a permutation matrix P, and an upper trapezoidal +C matrix R with diagonal elements of nonincreasing magnitude, +C such that A*P = Q*R. The Householder transformation for +C column K, K = 1,2,...,MIN(M,N), is of the form +C +C T +C I - (1/U(K))*U*U +C +C where U has zeros in the first K-1 positions. The form of +C this transformation and the method of pivoting first +C appeared in the corresponding LINPACK subroutine. +C +C The subroutine statement is +C +C SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,SIGMA,ACNORM,WA) +C +C where +C +C M is a positive integer input variable set to the number +C of rows of A. +C +C N is a positive integer input variable set to the number +C of columns of A. +C +C A is an M by N array. On input A contains the matrix for +C which the QR factorization is to be computed. On output +C the strict upper trapezoidal part of A contains the strict +C upper trapezoidal part of R, and the lower trapezoidal +C part of A contains a factored form of Q (the non-trivial +C elements of the U vectors described above). +C +C LDA is a positive integer input variable not less than M +C which specifies the leading dimension of the array A. +C +C PIVOT is a logical input variable. If pivot is set .TRUE., +C then column pivoting is enforced. If pivot is set .FALSE., +C then no column pivoting is done. +C +C IPVT is an integer output array of length LIPVT. IPVT +C defines the permutation matrix P such that A*P = Q*R. +C Column J of P is column IPVT(J) of the identity matrix. +C If pivot is .FALSE., IPVT is not referenced. +C +C LIPVT is a positive integer input variable. If PIVOT is +C .FALSE., then LIPVT may be as small as 1. If PIVOT is +C .TRUE., then LIPVT must be at least N. +C +C SIGMA is an output array of length N which contains the +C diagonal elements of R. +C +C ACNORM is an output array of length N which contains the +C norms of the corresponding columns of the input matrix A. +C If this information is not needed, then ACNORM can coincide +C with SIGMA. +C +C WA is a work array of length N. If pivot is .FALSE., then WA +C can coincide with SIGMA. +C +C***SEE ALSO SNLS1, SNLS1E, SNSQ, SNSQE +C***ROUTINES CALLED ENORM, R1MACH +C***REVISION HISTORY (YYMMDD) +C 800301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 900328 Added TYPE section. (WRB) +C***END PROLOGUE QRFAC + INTEGER M,N,LDA,LIPVT + INTEGER IPVT(*) + LOGICAL PIVOT + REAL A(LDA,*),SIGMA(*),ACNORM(*),WA(*) + INTEGER I,J,JP1,K,KMAX,MINMN + REAL AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO + REAL R1MACH,ENORM + SAVE ONE, P05, ZERO + DATA ONE,P05,ZERO /1.0E0,5.0E-2,0.0E0/ +C***FIRST EXECUTABLE STATEMENT QRFAC + EPSMCH = R1MACH(4) +C +C COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS. +C + DO 10 J = 1, N + ACNORM(J) = ENORM(M,A(1,J)) + SIGMA(J) = ACNORM(J) + WA(J) = SIGMA(J) + IF (PIVOT) IPVT(J) = J + 10 CONTINUE +C +C REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS. +C + MINMN = MIN(M,N) + DO 110 J = 1, MINMN + IF (.NOT.PIVOT) GO TO 40 +C +C BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION. +C + KMAX = J + DO 20 K = J, N + IF (SIGMA(K) .GT. SIGMA(KMAX)) KMAX = K + 20 CONTINUE + IF (KMAX .EQ. J) GO TO 40 + DO 30 I = 1, M + TEMP = A(I,J) + A(I,J) = A(I,KMAX) + A(I,KMAX) = TEMP + 30 CONTINUE + SIGMA(KMAX) = SIGMA(J) + WA(KMAX) = WA(J) + K = IPVT(J) + IPVT(J) = IPVT(KMAX) + IPVT(KMAX) = K + 40 CONTINUE +C +C COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE +C J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR. +C + AJNORM = ENORM(M-J+1,A(J,J)) + IF (AJNORM .EQ. ZERO) GO TO 100 + IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM + DO 50 I = J, M + A(I,J) = A(I,J)/AJNORM + 50 CONTINUE + A(J,J) = A(J,J) + ONE +C +C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS +C AND UPDATE THE NORMS. +C + JP1 = J + 1 + IF (N .LT. JP1) GO TO 100 + DO 90 K = JP1, N + SUM = ZERO + DO 60 I = J, M + SUM = SUM + A(I,J)*A(I,K) + 60 CONTINUE + TEMP = SUM/A(J,J) + DO 70 I = J, M + A(I,K) = A(I,K) - TEMP*A(I,J) + 70 CONTINUE + IF (.NOT.PIVOT .OR. SIGMA(K) .EQ. ZERO) GO TO 80 + TEMP = A(J,K)/SIGMA(K) + SIGMA(K) = SIGMA(K)*SQRT(MAX(ZERO,ONE-TEMP**2)) + IF (P05*(SIGMA(K)/WA(K))**2 .GT. EPSMCH) GO TO 80 + SIGMA(K) = ENORM(M-J,A(JP1,K)) + WA(K) = SIGMA(K) + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + SIGMA(J) = -AJNORM + 110 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE QRFAC. +C + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/qrsolv.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/qrsolv.f new file mode 100644 index 0000000..813c247 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/qrsolv.f @@ -0,0 +1,198 @@ +*DECK QRSOLV + SUBROUTINE QRSOLV (N, R, LDR, IPVT, DIAG, QTB, X, SIGMA, WA) +C***BEGIN PROLOGUE QRSOLV +C***SUBSIDIARY +C***PURPOSE Subsidiary to SNLS1 and SNLS1E +C***LIBRARY SLATEC +C***TYPE SINGLE PRECISION (QRSOLV-S, DQRSLV-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C Given an M by N matrix A, an N by N diagonal matrix D, +C and an M-vector B, the problem is to determine an X which +C solves the system +C +C A*X = B , D*X = 0 , +C +C in the least squares sense. +C +C This subroutine completes the solution of the problem +C if it is provided with the necessary information from the +C QR factorization, with column pivoting, of A. That is, if +C A*P = Q*R, where P is a permutation matrix, Q has orthogonal +C columns, and R is an upper triangular matrix with diagonal +C elements of nonincreasing magnitude, then QRSOLV expects +C the full upper triangle of R, the permutation matrix P, +C and the first N components of (Q TRANSPOSE)*B. The system +C A*X = B, D*X = 0, is then equivalent to +C +C T T +C R*Z = Q *B , P *D*P*Z = 0 , +C +C where X = P*Z. If this system does not have full rank, +C then a least squares solution is obtained. On output QRSOLV +C also provides an upper triangular matrix S such that +C +C T T T +C P *(A *A + D*D)*P = S *S . +C +C S is computed within QRSOLV and may be of separate interest. +C +C The subroutine statement is +C +C SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SIGMA,WA) +C +C where +C +C N is a positive integer input variable set to the order of R. +C +C R is an N by N array. On input the full upper triangle +C must contain the full upper triangle of the matrix R. +C On output the full upper triangle is unaltered, and the +C strict lower triangle contains the strict upper triangle +C (transposed) of the upper triangular matrix S. +C +C LDR is a positive integer input variable not less than N +C which specifies the leading dimension of the array R. +C +C IPVT is an integer input array of length N which defines the +C permutation matrix P such that A*P = Q*R. Column J of P +C is column IPVT(J) of the identity matrix. +C +C DIAG is an input array of length N which must contain the +C diagonal elements of the matrix D. +C +C QTB is an input array of length N which must contain the first +C N elements of the vector (Q TRANSPOSE)*B. +C +C X is an output array of length N which contains the least +C squares solution of the system A*X = B, D*X = 0. +C +C SIGMA is an output array of length N which contains the +C diagonal elements of the upper triangular matrix S. +C +C WA is a work array of length N. +C +C***SEE ALSO SNLS1, SNLS1E +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 800301 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 900328 Added TYPE section. (WRB) +C***END PROLOGUE QRSOLV + INTEGER N,LDR + INTEGER IPVT(*) + REAL R(LDR,*),DIAG(*),QTB(*),X(*),SIGMA(*),WA(*) + INTEGER I,J,JP1,K,KP1,L,NSING + REAL COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO + SAVE P5, P25, ZERO + DATA P5,P25,ZERO /5.0E-1,2.5E-1,0.0E0/ +C***FIRST EXECUTABLE STATEMENT QRSOLV + DO 20 J = 1, N + DO 10 I = J, N + R(I,J) = R(J,I) + 10 CONTINUE + X(J) = R(J,J) + WA(J) = QTB(J) + 20 CONTINUE +C +C ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION. +C + DO 100 J = 1, N +C +C PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE +C DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION. +C + L = IPVT(J) + IF (DIAG(L) .EQ. ZERO) GO TO 90 + DO 30 K = J, N + SIGMA(K) = ZERO + 30 CONTINUE + SIGMA(J) = DIAG(L) +C +C THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D +C MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B +C BEYOND THE FIRST N, WHICH IS INITIALLY ZERO. +C + QTBPJ = ZERO + DO 80 K = J, N +C +C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE +C APPROPRIATE ELEMENT IN THE CURRENT ROW OF D. +C + IF (SIGMA(K) .EQ. ZERO) GO TO 70 + IF (ABS(R(K,K)) .GE. ABS(SIGMA(K))) GO TO 40 + COTAN = R(K,K)/SIGMA(K) + SIN = P5/SQRT(P25+P25*COTAN**2) + COS = SIN*COTAN + GO TO 50 + 40 CONTINUE + TAN = SIGMA(K)/R(K,K) + COS = P5/SQRT(P25+P25*TAN**2) + SIN = COS*TAN + 50 CONTINUE +C +C COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND +C THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0). +C + R(K,K) = COS*R(K,K) + SIN*SIGMA(K) + TEMP = COS*WA(K) + SIN*QTBPJ + QTBPJ = -SIN*WA(K) + COS*QTBPJ + WA(K) = TEMP +C +C ACCUMULATE THE TRANSFORMATION IN THE ROW OF S. +C + KP1 = K + 1 + IF (N .LT. KP1) GO TO 70 + DO 60 I = KP1, N + TEMP = COS*R(I,K) + SIN*SIGMA(I) + SIGMA(I) = -SIN*R(I,K) + COS*SIGMA(I) + R(I,K) = TEMP + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +C +C STORE THE DIAGONAL ELEMENT OF S AND RESTORE +C THE CORRESPONDING DIAGONAL ELEMENT OF R. +C + SIGMA(J) = R(J,J) + R(J,J) = X(J) + 100 CONTINUE +C +C SOLVE THE TRIANGULAR SYSTEM FOR Z. IF THE SYSTEM IS +C SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION. +C + NSING = N + DO 110 J = 1, N + IF (SIGMA(J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 + IF (NSING .LT. N) WA(J) = ZERO + 110 CONTINUE + IF (NSING .LT. 1) GO TO 150 + DO 140 K = 1, NSING + J = NSING - K + 1 + SUM = ZERO + JP1 = J + 1 + IF (NSING .LT. JP1) GO TO 130 + DO 120 I = JP1, NSING + SUM = SUM + R(I,J)*WA(I) + 120 CONTINUE + 130 CONTINUE + WA(J) = (WA(J) - SUM)/SIGMA(J) + 140 CONTINUE + 150 CONTINUE +C +C PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X. +C + DO 160 J = 1, N + L = IPVT(J) + X(L) = WA(J) + 160 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE QRSOLV. +C + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/r1mach.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/r1mach.f new file mode 100644 index 0000000..316afe4 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/r1mach.f @@ -0,0 +1,21 @@ + FUNCTION r1MACH (I) +c this is not the original one from slatec + dimension const(5) +c small: + DATA const(1) / 1.18E-38 / +c large: + DATA const(2) / 3.40E+38 / +c diff: + DATA const(3) / 0.595E-07 / + DATA const(4) / 1.19E-07 / +c log10: + DATA const(5) / 0.30102999566 / + +C***FIRST EXECUTABLE STATEMENT R1MACH +C + R1MACH = const(I) + RETURN +C + END + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb2.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb2.f new file mode 100644 index 0000000..7bff5de --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb2.f @@ -0,0 +1,61 @@ +*DECK RADB2 + SUBROUTINE RADB2 (IDO, L1, CC, CH, WA1) +C***BEGIN PROLOGUE RADB2 +C***SUBSIDIARY +C***PURPOSE Calculate the fast Fourier transform of subvectors of +C length two. +C***LIBRARY SLATEC (FFTPACK) +C***TYPE SINGLE PRECISION (RADB2-S) +C***AUTHOR Swarztrauber, P. N., (NCAR) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790601 DATE WRITTEN +C 830401 Modified to use SLATEC library source file format. +C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by +C changing dummy array size declarations (1) to (*). +C 881128 Modified by Dick Valent to meet prologue standards. +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900402 Added TYPE section. (WRB) +C***END PROLOGUE RADB2 + DIMENSION CC(IDO,2,*), CH(IDO,L1,2), WA1(*) +C***FIRST EXECUTABLE STATEMENT RADB2 + DO 101 K=1,L1 + CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) + CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) + 101 CONTINUE + IF (IDO-2) 107,105,102 + 102 IDP2 = IDO+2 + IF((IDO-1)/2.LT.L1) GO TO 108 + DO 104 K=1,L1 +CDIR$ IVDEP + DO 103 I=3,IDO,2 + IC = IDP2-I + CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) + TR2 = CC(I-1,1,K)-CC(IC-1,2,K) + CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) + TI2 = CC(I,1,K)+CC(IC,2,K) + CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 + CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 + 103 CONTINUE + 104 CONTINUE + GO TO 111 + 108 DO 110 I=3,IDO,2 + IC = IDP2-I +CDIR$ IVDEP + DO 109 K=1,L1 + CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) + TR2 = CC(I-1,1,K)-CC(IC-1,2,K) + CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) + TI2 = CC(I,1,K)+CC(IC,2,K) + CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 + CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 + 109 CONTINUE + 110 CONTINUE + 111 IF (MOD(IDO,2) .EQ. 1) RETURN + 105 DO 106 K=1,L1 + CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K) + CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K)) + 106 CONTINUE + 107 RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb3.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb3.f new file mode 100644 index 0000000..ae40565 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb3.f @@ -0,0 +1,85 @@ +*DECK RADB3 + SUBROUTINE RADB3 (IDO, L1, CC, CH, WA1, WA2) +C***BEGIN PROLOGUE RADB3 +C***SUBSIDIARY +C***PURPOSE Calculate the fast Fourier transform of subvectors of +C length three. +C***LIBRARY SLATEC (FFTPACK) +C***TYPE SINGLE PRECISION (RADB3-S) +C***AUTHOR Swarztrauber, P. N., (NCAR) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790601 DATE WRITTEN +C 830401 Modified to use SLATEC library source file format. +C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by +C (a) changing dummy array size declarations (1) to (*), +C (b) changing definition of variable TAUI by using +C FORTRAN intrinsic function SQRT instead of a DATA +C statement. +C 881128 Modified by Dick Valent to meet prologue standards. +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900402 Added TYPE section. (WRB) +C***END PROLOGUE RADB3 + DIMENSION CC(IDO,3,*), CH(IDO,L1,3), WA1(*), WA2(*) +C***FIRST EXECUTABLE STATEMENT RADB3 + TAUR = -.5 + TAUI = .5*SQRT(3.) + DO 101 K=1,L1 + TR2 = CC(IDO,2,K)+CC(IDO,2,K) + CR2 = CC(1,1,K)+TAUR*TR2 + CH(1,K,1) = CC(1,1,K)+TR2 + CI3 = TAUI*(CC(1,3,K)+CC(1,3,K)) + CH(1,K,2) = CR2-CI3 + CH(1,K,3) = CR2+CI3 + 101 CONTINUE + IF (IDO .EQ. 1) RETURN + IDP2 = IDO+2 + IF((IDO-1)/2.LT.L1) GO TO 104 + DO 103 K=1,L1 +CDIR$ IVDEP + DO 102 I=3,IDO,2 + IC = IDP2-I + TR2 = CC(I-1,3,K)+CC(IC-1,2,K) + CR2 = CC(I-1,1,K)+TAUR*TR2 + CH(I-1,K,1) = CC(I-1,1,K)+TR2 + TI2 = CC(I,3,K)-CC(IC,2,K) + CI2 = CC(I,1,K)+TAUR*TI2 + CH(I,K,1) = CC(I,1,K)+TI2 + CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) + CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) + DR2 = CR2-CI3 + DR3 = CR2+CI3 + DI2 = CI2+CR3 + DI3 = CI2-CR3 + CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 + CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 + CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 + CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 + 102 CONTINUE + 103 CONTINUE + RETURN + 104 DO 106 I=3,IDO,2 + IC = IDP2-I +CDIR$ IVDEP + DO 105 K=1,L1 + TR2 = CC(I-1,3,K)+CC(IC-1,2,K) + CR2 = CC(I-1,1,K)+TAUR*TR2 + CH(I-1,K,1) = CC(I-1,1,K)+TR2 + TI2 = CC(I,3,K)-CC(IC,2,K) + CI2 = CC(I,1,K)+TAUR*TI2 + CH(I,K,1) = CC(I,1,K)+TI2 + CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) + CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) + DR2 = CR2-CI3 + DR3 = CR2+CI3 + DI2 = CI2+CR3 + DI3 = CI2-CR3 + CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 + CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 + CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 + CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 + 105 CONTINUE + 106 CONTINUE + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb4.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb4.f new file mode 100644 index 0000000..7f88c9c --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb4.f @@ -0,0 +1,109 @@ +*DECK RADB4 + SUBROUTINE RADB4 (IDO, L1, CC, CH, WA1, WA2, WA3) +C***BEGIN PROLOGUE RADB4 +C***SUBSIDIARY +C***PURPOSE Calculate the fast Fourier transform of subvectors of +C length four. +C***LIBRARY SLATEC (FFTPACK) +C***TYPE SINGLE PRECISION (RADB4-S) +C***AUTHOR Swarztrauber, P. N., (NCAR) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790601 DATE WRITTEN +C 830401 Modified to use SLATEC library source file format. +C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by +C (a) changing dummy array size declarations (1) to (*), +C (b) changing definition of variable SQRT2 by using +C FORTRAN intrinsic function SQRT instead of a DATA +C statement. +C 881128 Modified by Dick Valent to meet prologue standards. +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900402 Added TYPE section. (WRB) +C***END PROLOGUE RADB4 + DIMENSION CC(IDO,4,*), CH(IDO,L1,4), WA1(*), WA2(*), WA3(*) +C***FIRST EXECUTABLE STATEMENT RADB4 + SQRT2 = SQRT(2.) + DO 101 K=1,L1 + TR1 = CC(1,1,K)-CC(IDO,4,K) + TR2 = CC(1,1,K)+CC(IDO,4,K) + TR3 = CC(IDO,2,K)+CC(IDO,2,K) + TR4 = CC(1,3,K)+CC(1,3,K) + CH(1,K,1) = TR2+TR3 + CH(1,K,2) = TR1-TR4 + CH(1,K,3) = TR2-TR3 + CH(1,K,4) = TR1+TR4 + 101 CONTINUE + IF (IDO-2) 107,105,102 + 102 IDP2 = IDO+2 + IF((IDO-1)/2.LT.L1) GO TO 108 + DO 104 K=1,L1 +CDIR$ IVDEP + DO 103 I=3,IDO,2 + IC = IDP2-I + TI1 = CC(I,1,K)+CC(IC,4,K) + TI2 = CC(I,1,K)-CC(IC,4,K) + TI3 = CC(I,3,K)-CC(IC,2,K) + TR4 = CC(I,3,K)+CC(IC,2,K) + TR1 = CC(I-1,1,K)-CC(IC-1,4,K) + TR2 = CC(I-1,1,K)+CC(IC-1,4,K) + TI4 = CC(I-1,3,K)-CC(IC-1,2,K) + TR3 = CC(I-1,3,K)+CC(IC-1,2,K) + CH(I-1,K,1) = TR2+TR3 + CR3 = TR2-TR3 + CH(I,K,1) = TI2+TI3 + CI3 = TI2-TI3 + CR2 = TR1-TR4 + CR4 = TR1+TR4 + CI2 = TI1+TI4 + CI4 = TI1-TI4 + CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 + CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 + CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 + CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 + CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 + CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 + 103 CONTINUE + 104 CONTINUE + GO TO 111 + 108 DO 110 I=3,IDO,2 + IC = IDP2-I +CDIR$ IVDEP + DO 109 K=1,L1 + TI1 = CC(I,1,K)+CC(IC,4,K) + TI2 = CC(I,1,K)-CC(IC,4,K) + TI3 = CC(I,3,K)-CC(IC,2,K) + TR4 = CC(I,3,K)+CC(IC,2,K) + TR1 = CC(I-1,1,K)-CC(IC-1,4,K) + TR2 = CC(I-1,1,K)+CC(IC-1,4,K) + TI4 = CC(I-1,3,K)-CC(IC-1,2,K) + TR3 = CC(I-1,3,K)+CC(IC-1,2,K) + CH(I-1,K,1) = TR2+TR3 + CR3 = TR2-TR3 + CH(I,K,1) = TI2+TI3 + CI3 = TI2-TI3 + CR2 = TR1-TR4 + CR4 = TR1+TR4 + CI2 = TI1+TI4 + CI4 = TI1-TI4 + CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 + CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 + CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 + CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 + CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 + CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 + 109 CONTINUE + 110 CONTINUE + 111 IF (MOD(IDO,2) .EQ. 1) RETURN + 105 DO 106 K=1,L1 + TI1 = CC(1,2,K)+CC(1,4,K) + TI2 = CC(1,4,K)-CC(1,2,K) + TR1 = CC(IDO,1,K)-CC(IDO,3,K) + TR2 = CC(IDO,1,K)+CC(IDO,3,K) + CH(IDO,K,1) = TR2+TR2 + CH(IDO,K,2) = SQRT2*(TR1-TI1) + CH(IDO,K,3) = TI2+TI2 + CH(IDO,K,4) = -SQRT2*(TR1+TI1) + 106 CONTINUE + 107 RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb5.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb5.f new file mode 100644 index 0000000..bf72475 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radb5.f @@ -0,0 +1,132 @@ +*DECK RADB5 + SUBROUTINE RADB5 (IDO, L1, CC, CH, WA1, WA2, WA3, WA4) +C***BEGIN PROLOGUE RADB5 +C***SUBSIDIARY +C***PURPOSE Calculate the fast Fourier transform of subvectors of +C length five. +C***LIBRARY SLATEC (FFTPACK) +C***TYPE SINGLE PRECISION (RADB5-S) +C***AUTHOR Swarztrauber, P. N., (NCAR) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790601 DATE WRITTEN +C 830401 Modified to use SLATEC library source file format. +C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by +C (a) changing dummy array size declarations (1) to (*), +C (b) changing definition of variables PI, TI11, TI12, +C TR11, TR12 by using FORTRAN intrinsic functions ATAN +C and SIN instead of DATA statements. +C 881128 Modified by Dick Valent to meet prologue standards. +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900402 Added TYPE section. (WRB) +C***END PROLOGUE RADB5 + DIMENSION CC(IDO,5,*), CH(IDO,L1,5), WA1(*), WA2(*), WA3(*), + + WA4(*) +C***FIRST EXECUTABLE STATEMENT RADB5 + PI = 4.*ATAN(1.) + TR11 = SIN(.1*PI) + TI11 = SIN(.4*PI) + TR12 = -SIN(.3*PI) + TI12 = SIN(.2*PI) + DO 101 K=1,L1 + TI5 = CC(1,3,K)+CC(1,3,K) + TI4 = CC(1,5,K)+CC(1,5,K) + TR2 = CC(IDO,2,K)+CC(IDO,2,K) + TR3 = CC(IDO,4,K)+CC(IDO,4,K) + CH(1,K,1) = CC(1,1,K)+TR2+TR3 + CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 + CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 + CI5 = TI11*TI5+TI12*TI4 + CI4 = TI12*TI5-TI11*TI4 + CH(1,K,2) = CR2-CI5 + CH(1,K,3) = CR3-CI4 + CH(1,K,4) = CR3+CI4 + CH(1,K,5) = CR2+CI5 + 101 CONTINUE + IF (IDO .EQ. 1) RETURN + IDP2 = IDO+2 + IF((IDO-1)/2.LT.L1) GO TO 104 + DO 103 K=1,L1 +CDIR$ IVDEP + DO 102 I=3,IDO,2 + IC = IDP2-I + TI5 = CC(I,3,K)+CC(IC,2,K) + TI2 = CC(I,3,K)-CC(IC,2,K) + TI4 = CC(I,5,K)+CC(IC,4,K) + TI3 = CC(I,5,K)-CC(IC,4,K) + TR5 = CC(I-1,3,K)-CC(IC-1,2,K) + TR2 = CC(I-1,3,K)+CC(IC-1,2,K) + TR4 = CC(I-1,5,K)-CC(IC-1,4,K) + TR3 = CC(I-1,5,K)+CC(IC-1,4,K) + CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 + CH(I,K,1) = CC(I,1,K)+TI2+TI3 + CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 + CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 + CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 + CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 + CR5 = TI11*TR5+TI12*TR4 + CI5 = TI11*TI5+TI12*TI4 + CR4 = TI12*TR5-TI11*TR4 + CI4 = TI12*TI5-TI11*TI4 + DR3 = CR3-CI4 + DR4 = CR3+CI4 + DI3 = CI3+CR4 + DI4 = CI3-CR4 + DR5 = CR2+CI5 + DR2 = CR2-CI5 + DI5 = CI2-CR5 + DI2 = CI2+CR5 + CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 + CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 + CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 + CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 + CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 + CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 + CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 + CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 + 102 CONTINUE + 103 CONTINUE + RETURN + 104 DO 106 I=3,IDO,2 + IC = IDP2-I +CDIR$ IVDEP + DO 105 K=1,L1 + TI5 = CC(I,3,K)+CC(IC,2,K) + TI2 = CC(I,3,K)-CC(IC,2,K) + TI4 = CC(I,5,K)+CC(IC,4,K) + TI3 = CC(I,5,K)-CC(IC,4,K) + TR5 = CC(I-1,3,K)-CC(IC-1,2,K) + TR2 = CC(I-1,3,K)+CC(IC-1,2,K) + TR4 = CC(I-1,5,K)-CC(IC-1,4,K) + TR3 = CC(I-1,5,K)+CC(IC-1,4,K) + CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 + CH(I,K,1) = CC(I,1,K)+TI2+TI3 + CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 + CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 + CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 + CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 + CR5 = TI11*TR5+TI12*TR4 + CI5 = TI11*TI5+TI12*TI4 + CR4 = TI12*TR5-TI11*TR4 + CI4 = TI12*TI5-TI11*TI4 + DR3 = CR3-CI4 + DR4 = CR3+CI4 + DI3 = CI3+CR4 + DI4 = CI3-CR4 + DR5 = CR2+CI5 + DR2 = CR2-CI5 + DI5 = CI2-CR5 + DI2 = CI2+CR5 + CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 + CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 + CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 + CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 + CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 + CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 + CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 + CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 + 105 CONTINUE + 106 CONTINUE + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radbg.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radbg.f new file mode 100644 index 0000000..e8ccc06 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radbg.f @@ -0,0 +1,189 @@ +*DECK RADBG + SUBROUTINE RADBG (IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA) +C***BEGIN PROLOGUE RADBG +C***SUBSIDIARY +C***PURPOSE Calculate the fast Fourier transform of subvectors of +C arbitrary length. +C***LIBRARY SLATEC (FFTPACK) +C***TYPE SINGLE PRECISION (RADBG-S) +C***AUTHOR Swarztrauber, P. N., (NCAR) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790601 DATE WRITTEN +C 830401 Modified to use SLATEC library source file format. +C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by +C (a) changing dummy array size declarations (1) to (*), +C (b) changing references to intrinsic function FLOAT +C to REAL, and +C (c) changing definition of variable TPI by using +C FORTRAN intrinsic function ATAN instead of a DATA +C statement. +C 881128 Modified by Dick Valent to meet prologue standards. +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900402 Added TYPE section. (WRB) +C***END PROLOGUE RADBG + DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), + + C2(IDL1,*), CH2(IDL1,*), WA(*) +C***FIRST EXECUTABLE STATEMENT RADBG + TPI = 8.*ATAN(1.) + ARG = TPI/IP + DCP = COS(ARG) + DSP = SIN(ARG) + IDP2 = IDO+2 + NBD = (IDO-1)/2 + IPP2 = IP+2 + IPPH = (IP+1)/2 + IF (IDO .LT. L1) GO TO 103 + DO 102 K=1,L1 + DO 101 I=1,IDO + CH(I,K,1) = CC(I,1,K) + 101 CONTINUE + 102 CONTINUE + GO TO 106 + 103 DO 105 I=1,IDO + DO 104 K=1,L1 + CH(I,K,1) = CC(I,1,K) + 104 CONTINUE + 105 CONTINUE + 106 DO 108 J=2,IPPH + JC = IPP2-J + J2 = J+J + DO 107 K=1,L1 + CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K) + CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K) + 107 CONTINUE + 108 CONTINUE + IF (IDO .EQ. 1) GO TO 116 + IF (NBD .LT. L1) GO TO 112 + DO 111 J=2,IPPH + JC = IPP2-J + DO 110 K=1,L1 +CDIR$ IVDEP + DO 109 I=3,IDO,2 + IC = IDP2-I + CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) + CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) + CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) + CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) + 109 CONTINUE + 110 CONTINUE + 111 CONTINUE + GO TO 116 + 112 DO 115 J=2,IPPH + JC = IPP2-J +CDIR$ IVDEP + DO 114 I=3,IDO,2 + IC = IDP2-I + DO 113 K=1,L1 + CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) + CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) + CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) + CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) + 113 CONTINUE + 114 CONTINUE + 115 CONTINUE + 116 AR1 = 1. + AI1 = 0. + DO 120 L=2,IPPH + LC = IPP2-L + AR1H = DCP*AR1-DSP*AI1 + AI1 = DCP*AI1+DSP*AR1 + AR1 = AR1H + DO 117 IK=1,IDL1 + C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2) + C2(IK,LC) = AI1*CH2(IK,IP) + 117 CONTINUE + DC2 = AR1 + DS2 = AI1 + AR2 = AR1 + AI2 = AI1 + DO 119 J=3,IPPH + JC = IPP2-J + AR2H = DC2*AR2-DS2*AI2 + AI2 = DC2*AI2+DS2*AR2 + AR2 = AR2H + DO 118 IK=1,IDL1 + C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J) + C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC) + 118 CONTINUE + 119 CONTINUE + 120 CONTINUE + DO 122 J=2,IPPH + DO 121 IK=1,IDL1 + CH2(IK,1) = CH2(IK,1)+CH2(IK,J) + 121 CONTINUE + 122 CONTINUE + DO 124 J=2,IPPH + JC = IPP2-J + DO 123 K=1,L1 + CH(1,K,J) = C1(1,K,J)-C1(1,K,JC) + CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC) + 123 CONTINUE + 124 CONTINUE + IF (IDO .EQ. 1) GO TO 132 + IF (NBD .LT. L1) GO TO 128 + DO 127 J=2,IPPH + JC = IPP2-J + DO 126 K=1,L1 +CDIR$ IVDEP + DO 125 I=3,IDO,2 + CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) + CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) + CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) + CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) + 125 CONTINUE + 126 CONTINUE + 127 CONTINUE + GO TO 132 + 128 DO 131 J=2,IPPH + JC = IPP2-J + DO 130 I=3,IDO,2 + DO 129 K=1,L1 + CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) + CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) + CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) + CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) + 129 CONTINUE + 130 CONTINUE + 131 CONTINUE + 132 CONTINUE + IF (IDO .EQ. 1) RETURN + DO 133 IK=1,IDL1 + C2(IK,1) = CH2(IK,1) + 133 CONTINUE + DO 135 J=2,IP + DO 134 K=1,L1 + C1(1,K,J) = CH(1,K,J) + 134 CONTINUE + 135 CONTINUE + IF (NBD .GT. L1) GO TO 139 + IS = -IDO + DO 138 J=2,IP + IS = IS+IDO + IDIJ = IS + DO 137 I=3,IDO,2 + IDIJ = IDIJ+2 + DO 136 K=1,L1 + C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) + C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) + 136 CONTINUE + 137 CONTINUE + 138 CONTINUE + GO TO 143 + 139 IS = -IDO + DO 142 J=2,IP + IS = IS+IDO + DO 141 K=1,L1 + IDIJ = IS +CDIR$ IVDEP + DO 140 I=3,IDO,2 + IDIJ = IDIJ+2 + C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) + C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE + 143 RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf2.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf2.f new file mode 100644 index 0000000..99a50e5 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf2.f @@ -0,0 +1,61 @@ +*DECK RADF2 + SUBROUTINE RADF2 (IDO, L1, CC, CH, WA1) +C***BEGIN PROLOGUE RADF2 +C***SUBSIDIARY +C***PURPOSE Calculate the fast Fourier transform of subvectors of +C length two. +C***LIBRARY SLATEC (FFTPACK) +C***TYPE SINGLE PRECISION (RADF2-S) +C***AUTHOR Swarztrauber, P. N., (NCAR) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790601 DATE WRITTEN +C 830401 Modified to use SLATEC library source file format. +C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by +C changing dummy array size declarations (1) to (*). +C 881128 Modified by Dick Valent to meet prologue standards. +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900402 Added TYPE section. (WRB) +C***END PROLOGUE RADF2 + DIMENSION CH(IDO,2,*), CC(IDO,L1,2), WA1(*) +C***FIRST EXECUTABLE STATEMENT RADF2 + DO 101 K=1,L1 + CH(1,1,K) = CC(1,K,1)+CC(1,K,2) + CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) + 101 CONTINUE + IF (IDO-2) 107,105,102 + 102 IDP2 = IDO+2 + IF((IDO-1)/2.LT.L1) GO TO 108 + DO 104 K=1,L1 +CDIR$ IVDEP + DO 103 I=3,IDO,2 + IC = IDP2-I + TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) + TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) + CH(I,1,K) = CC(I,K,1)+TI2 + CH(IC,2,K) = TI2-CC(I,K,1) + CH(I-1,1,K) = CC(I-1,K,1)+TR2 + CH(IC-1,2,K) = CC(I-1,K,1)-TR2 + 103 CONTINUE + 104 CONTINUE + GO TO 111 + 108 DO 110 I=3,IDO,2 + IC = IDP2-I +CDIR$ IVDEP + DO 109 K=1,L1 + TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) + TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) + CH(I,1,K) = CC(I,K,1)+TI2 + CH(IC,2,K) = TI2-CC(I,K,1) + CH(I-1,1,K) = CC(I-1,K,1)+TR2 + CH(IC-1,2,K) = CC(I-1,K,1)-TR2 + 109 CONTINUE + 110 CONTINUE + 111 IF (MOD(IDO,2) .EQ. 1) RETURN + 105 DO 106 K=1,L1 + CH(1,2,K) = -CC(IDO,K,2) + CH(IDO,1,K) = CC(IDO,K,1) + 106 CONTINUE + 107 RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf3.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf3.f new file mode 100644 index 0000000..6449e32 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf3.f @@ -0,0 +1,83 @@ +*DECK RADF3 + SUBROUTINE RADF3 (IDO, L1, CC, CH, WA1, WA2) +C***BEGIN PROLOGUE RADF3 +C***SUBSIDIARY +C***PURPOSE Calculate the fast Fourier transform of subvectors of +C length three. +C***LIBRARY SLATEC (FFTPACK) +C***TYPE SINGLE PRECISION (RADF3-S) +C***AUTHOR Swarztrauber, P. N., (NCAR) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790601 DATE WRITTEN +C 830401 Modified to use SLATEC library source file format. +C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by +C (a) changing dummy array size declarations (1) to (*), +C (b) changing definition of variable TAUI by using +C FORTRAN intrinsic function SQRT instead of a DATA +C statement. +C 881128 Modified by Dick Valent to meet prologue standards. +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900402 Added TYPE section. (WRB) +C***END PROLOGUE RADF3 + DIMENSION CH(IDO,3,*), CC(IDO,L1,3), WA1(*), WA2(*) +C***FIRST EXECUTABLE STATEMENT RADF3 + TAUR = -.5 + TAUI = .5*SQRT(3.) + DO 101 K=1,L1 + CR2 = CC(1,K,2)+CC(1,K,3) + CH(1,1,K) = CC(1,K,1)+CR2 + CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2)) + CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2 + 101 CONTINUE + IF (IDO .EQ. 1) RETURN + IDP2 = IDO+2 + IF((IDO-1)/2.LT.L1) GO TO 104 + DO 103 K=1,L1 +CDIR$ IVDEP + DO 102 I=3,IDO,2 + IC = IDP2-I + DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) + DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) + DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) + DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) + CR2 = DR2+DR3 + CI2 = DI2+DI3 + CH(I-1,1,K) = CC(I-1,K,1)+CR2 + CH(I,1,K) = CC(I,K,1)+CI2 + TR2 = CC(I-1,K,1)+TAUR*CR2 + TI2 = CC(I,K,1)+TAUR*CI2 + TR3 = TAUI*(DI2-DI3) + TI3 = TAUI*(DR3-DR2) + CH(I-1,3,K) = TR2+TR3 + CH(IC-1,2,K) = TR2-TR3 + CH(I,3,K) = TI2+TI3 + CH(IC,2,K) = TI3-TI2 + 102 CONTINUE + 103 CONTINUE + RETURN + 104 DO 106 I=3,IDO,2 + IC = IDP2-I +CDIR$ IVDEP + DO 105 K=1,L1 + DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) + DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) + DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) + DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) + CR2 = DR2+DR3 + CI2 = DI2+DI3 + CH(I-1,1,K) = CC(I-1,K,1)+CR2 + CH(I,1,K) = CC(I,K,1)+CI2 + TR2 = CC(I-1,K,1)+TAUR*CR2 + TI2 = CC(I,K,1)+TAUR*CI2 + TR3 = TAUI*(DI2-DI3) + TI3 = TAUI*(DR3-DR2) + CH(I-1,3,K) = TR2+TR3 + CH(IC-1,2,K) = TR2-TR3 + CH(I,3,K) = TI2+TI3 + CH(IC,2,K) = TI3-TI2 + 105 CONTINUE + 106 CONTINUE + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf4.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf4.f new file mode 100644 index 0000000..1766c93 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf4.f @@ -0,0 +1,105 @@ +*DECK RADF4 + SUBROUTINE RADF4 (IDO, L1, CC, CH, WA1, WA2, WA3) +C***BEGIN PROLOGUE RADF4 +C***SUBSIDIARY +C***PURPOSE Calculate the fast Fourier transform of subvectors of +C length four. +C***LIBRARY SLATEC (FFTPACK) +C***TYPE SINGLE PRECISION (RADF4-S) +C***AUTHOR Swarztrauber, P. N., (NCAR) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790601 DATE WRITTEN +C 830401 Modified to use SLATEC library source file format. +C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by +C (a) changing dummy array size declarations (1) to (*). +C (b) changing definition of variable HSQT2 by using +C FORTRAN intrinsic function SQRT instead of a DATA +C statement. +C 881128 Modified by Dick Valent to meet prologue standards. +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900402 Added TYPE section. (WRB) +C***END PROLOGUE RADF4 + DIMENSION CC(IDO,L1,4), CH(IDO,4,*), WA1(*), WA2(*), WA3(*) +C***FIRST EXECUTABLE STATEMENT RADF4 + HSQT2 = .5*SQRT(2.) + DO 101 K=1,L1 + TR1 = CC(1,K,2)+CC(1,K,4) + TR2 = CC(1,K,1)+CC(1,K,3) + CH(1,1,K) = TR1+TR2 + CH(IDO,4,K) = TR2-TR1 + CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) + CH(1,3,K) = CC(1,K,4)-CC(1,K,2) + 101 CONTINUE + IF (IDO-2) 107,105,102 + 102 IDP2 = IDO+2 + IF((IDO-1)/2.LT.L1) GO TO 111 + DO 104 K=1,L1 +CDIR$ IVDEP + DO 103 I=3,IDO,2 + IC = IDP2-I + CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) + CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) + CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) + CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) + CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) + CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) + TR1 = CR2+CR4 + TR4 = CR4-CR2 + TI1 = CI2+CI4 + TI4 = CI2-CI4 + TI2 = CC(I,K,1)+CI3 + TI3 = CC(I,K,1)-CI3 + TR2 = CC(I-1,K,1)+CR3 + TR3 = CC(I-1,K,1)-CR3 + CH(I-1,1,K) = TR1+TR2 + CH(IC-1,4,K) = TR2-TR1 + CH(I,1,K) = TI1+TI2 + CH(IC,4,K) = TI1-TI2 + CH(I-1,3,K) = TI4+TR3 + CH(IC-1,2,K) = TR3-TI4 + CH(I,3,K) = TR4+TI3 + CH(IC,2,K) = TR4-TI3 + 103 CONTINUE + 104 CONTINUE + GO TO 110 + 111 DO 109 I=3,IDO,2 + IC = IDP2-I +CDIR$ IVDEP + DO 108 K=1,L1 + CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) + CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) + CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) + CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) + CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) + CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) + TR1 = CR2+CR4 + TR4 = CR4-CR2 + TI1 = CI2+CI4 + TI4 = CI2-CI4 + TI2 = CC(I,K,1)+CI3 + TI3 = CC(I,K,1)-CI3 + TR2 = CC(I-1,K,1)+CR3 + TR3 = CC(I-1,K,1)-CR3 + CH(I-1,1,K) = TR1+TR2 + CH(IC-1,4,K) = TR2-TR1 + CH(I,1,K) = TI1+TI2 + CH(IC,4,K) = TI1-TI2 + CH(I-1,3,K) = TI4+TR3 + CH(IC-1,2,K) = TR3-TI4 + CH(I,3,K) = TR4+TI3 + CH(IC,2,K) = TR4-TI3 + 108 CONTINUE + 109 CONTINUE + 110 IF (MOD(IDO,2) .EQ. 1) RETURN + 105 DO 106 K=1,L1 + TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) + TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) + CH(IDO,1,K) = TR1+CC(IDO,K,1) + CH(IDO,3,K) = CC(IDO,K,1)-TR1 + CH(1,2,K) = TI1-CC(IDO,K,3) + CH(1,4,K) = TI1+CC(IDO,K,3) + 106 CONTINUE + 107 RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf5.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf5.f new file mode 100644 index 0000000..9ffcc1f --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radf5.f @@ -0,0 +1,128 @@ +*DECK RADF5 + SUBROUTINE RADF5 (IDO, L1, CC, CH, WA1, WA2, WA3, WA4) +C***BEGIN PROLOGUE RADF5 +C***SUBSIDIARY +C***PURPOSE Calculate the fast Fourier transform of subvectors of +C length five. +C***LIBRARY SLATEC (FFTPACK) +C***TYPE SINGLE PRECISION (RADF5-S) +C***AUTHOR Swarztrauber, P. N., (NCAR) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790601 DATE WRITTEN +C 830401 Modified to use SLATEC library source file format. +C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by +C (a) changing dummy array size declarations (1) to (*), +C (b) changing definition of variables PI, TI11, TI12, +C TR11, TR12 by using FORTRAN intrinsic functions ATAN +C and SIN instead of DATA statements. +C 881128 Modified by Dick Valent to meet prologue standards. +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900402 Added TYPE section. (WRB) +C***END PROLOGUE RADF5 + DIMENSION CC(IDO,L1,5), CH(IDO,5,*), WA1(*), WA2(*), WA3(*), + + WA4(*) +C***FIRST EXECUTABLE STATEMENT RADF5 + PI = 4.*ATAN(1.) + TR11 = SIN(.1*PI) + TI11 = SIN(.4*PI) + TR12 = -SIN(.3*PI) + TI12 = SIN(.2*PI) + DO 101 K=1,L1 + CR2 = CC(1,K,5)+CC(1,K,2) + CI5 = CC(1,K,5)-CC(1,K,2) + CR3 = CC(1,K,4)+CC(1,K,3) + CI4 = CC(1,K,4)-CC(1,K,3) + CH(1,1,K) = CC(1,K,1)+CR2+CR3 + CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3 + CH(1,3,K) = TI11*CI5+TI12*CI4 + CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3 + CH(1,5,K) = TI12*CI5-TI11*CI4 + 101 CONTINUE + IF (IDO .EQ. 1) RETURN + IDP2 = IDO+2 + IF((IDO-1)/2.LT.L1) GO TO 104 + DO 103 K=1,L1 +CDIR$ IVDEP + DO 102 I=3,IDO,2 + IC = IDP2-I + DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) + DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) + DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) + DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) + DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) + DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) + DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) + DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) + CR2 = DR2+DR5 + CI5 = DR5-DR2 + CR5 = DI2-DI5 + CI2 = DI2+DI5 + CR3 = DR3+DR4 + CI4 = DR4-DR3 + CR4 = DI3-DI4 + CI3 = DI3+DI4 + CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 + CH(I,1,K) = CC(I,K,1)+CI2+CI3 + TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 + TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 + TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 + TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 + TR5 = TI11*CR5+TI12*CR4 + TI5 = TI11*CI5+TI12*CI4 + TR4 = TI12*CR5-TI11*CR4 + TI4 = TI12*CI5-TI11*CI4 + CH(I-1,3,K) = TR2+TR5 + CH(IC-1,2,K) = TR2-TR5 + CH(I,3,K) = TI2+TI5 + CH(IC,2,K) = TI5-TI2 + CH(I-1,5,K) = TR3+TR4 + CH(IC-1,4,K) = TR3-TR4 + CH(I,5,K) = TI3+TI4 + CH(IC,4,K) = TI4-TI3 + 102 CONTINUE + 103 CONTINUE + RETURN + 104 DO 106 I=3,IDO,2 + IC = IDP2-I +CDIR$ IVDEP + DO 105 K=1,L1 + DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) + DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) + DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) + DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) + DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) + DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) + DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) + DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) + CR2 = DR2+DR5 + CI5 = DR5-DR2 + CR5 = DI2-DI5 + CI2 = DI2+DI5 + CR3 = DR3+DR4 + CI4 = DR4-DR3 + CR4 = DI3-DI4 + CI3 = DI3+DI4 + CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 + CH(I,1,K) = CC(I,K,1)+CI2+CI3 + TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 + TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 + TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 + TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 + TR5 = TI11*CR5+TI12*CR4 + TI5 = TI11*CI5+TI12*CI4 + TR4 = TI12*CR5-TI11*CR4 + TI4 = TI12*CI5-TI11*CI4 + CH(I-1,3,K) = TR2+TR5 + CH(IC-1,2,K) = TR2-TR5 + CH(I,3,K) = TI2+TI5 + CH(IC,2,K) = TI5-TI2 + CH(I-1,5,K) = TR3+TR4 + CH(IC-1,4,K) = TR3-TR4 + CH(I,5,K) = TI3+TI4 + CH(IC,4,K) = TI4-TI3 + 105 CONTINUE + 106 CONTINUE + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radfg.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radfg.f new file mode 100644 index 0000000..ccb3d47 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/radfg.f @@ -0,0 +1,194 @@ +*DECK RADFG + SUBROUTINE RADFG (IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA) +C***BEGIN PROLOGUE RADFG +C***SUBSIDIARY +C***PURPOSE Calculate the fast Fourier transform of subvectors of +C arbitrary length. +C***LIBRARY SLATEC (FFTPACK) +C***TYPE SINGLE PRECISION (RADFG-S) +C***AUTHOR Swarztrauber, P. N., (NCAR) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790601 DATE WRITTEN +C 830401 Modified to use SLATEC library source file format. +C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by +C (a) changing dummy array size declarations (1) to (*), +C (b) changing references to intrinsic function FLOAT +C to REAL, and +C (c) changing definition of variable TPI by using +C FORTRAN intrinsic function ATAN instead of a DATA +C statement. +C 881128 Modified by Dick Valent to meet prologue standards. +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900402 Added TYPE section. (WRB) +C***END PROLOGUE RADFG + DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), + + C2(IDL1,*), CH2(IDL1,*), WA(*) +C***FIRST EXECUTABLE STATEMENT RADFG + TPI = 8.*ATAN(1.) + ARG = TPI/IP + DCP = COS(ARG) + DSP = SIN(ARG) + IPPH = (IP+1)/2 + IPP2 = IP+2 + IDP2 = IDO+2 + NBD = (IDO-1)/2 + IF (IDO .EQ. 1) GO TO 119 + DO 101 IK=1,IDL1 + CH2(IK,1) = C2(IK,1) + 101 CONTINUE + DO 103 J=2,IP + DO 102 K=1,L1 + CH(1,K,J) = C1(1,K,J) + 102 CONTINUE + 103 CONTINUE + IF (NBD .GT. L1) GO TO 107 + IS = -IDO + DO 106 J=2,IP + IS = IS+IDO + IDIJ = IS + DO 105 I=3,IDO,2 + IDIJ = IDIJ+2 + DO 104 K=1,L1 + CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) + CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) + 104 CONTINUE + 105 CONTINUE + 106 CONTINUE + GO TO 111 + 107 IS = -IDO + DO 110 J=2,IP + IS = IS+IDO + DO 109 K=1,L1 + IDIJ = IS +CDIR$ IVDEP + DO 108 I=3,IDO,2 + IDIJ = IDIJ+2 + CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) + CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) + 108 CONTINUE + 109 CONTINUE + 110 CONTINUE + 111 IF (NBD .LT. L1) GO TO 115 + DO 114 J=2,IPPH + JC = IPP2-J + DO 113 K=1,L1 +CDIR$ IVDEP + DO 112 I=3,IDO,2 + C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) + C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) + C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) + C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) + 112 CONTINUE + 113 CONTINUE + 114 CONTINUE + GO TO 121 + 115 DO 118 J=2,IPPH + JC = IPP2-J + DO 117 I=3,IDO,2 + DO 116 K=1,L1 + C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) + C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) + C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) + C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) + 116 CONTINUE + 117 CONTINUE + 118 CONTINUE + GO TO 121 + 119 DO 120 IK=1,IDL1 + C2(IK,1) = CH2(IK,1) + 120 CONTINUE + 121 DO 123 J=2,IPPH + JC = IPP2-J + DO 122 K=1,L1 + C1(1,K,J) = CH(1,K,J)+CH(1,K,JC) + C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J) + 122 CONTINUE + 123 CONTINUE +C + AR1 = 1. + AI1 = 0. + DO 127 L=2,IPPH + LC = IPP2-L + AR1H = DCP*AR1-DSP*AI1 + AI1 = DCP*AI1+DSP*AR1 + AR1 = AR1H + DO 124 IK=1,IDL1 + CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2) + CH2(IK,LC) = AI1*C2(IK,IP) + 124 CONTINUE + DC2 = AR1 + DS2 = AI1 + AR2 = AR1 + AI2 = AI1 + DO 126 J=3,IPPH + JC = IPP2-J + AR2H = DC2*AR2-DS2*AI2 + AI2 = DC2*AI2+DS2*AR2 + AR2 = AR2H + DO 125 IK=1,IDL1 + CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J) + CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC) + 125 CONTINUE + 126 CONTINUE + 127 CONTINUE + DO 129 J=2,IPPH + DO 128 IK=1,IDL1 + CH2(IK,1) = CH2(IK,1)+C2(IK,J) + 128 CONTINUE + 129 CONTINUE +C + IF (IDO .LT. L1) GO TO 132 + DO 131 K=1,L1 + DO 130 I=1,IDO + CC(I,1,K) = CH(I,K,1) + 130 CONTINUE + 131 CONTINUE + GO TO 135 + 132 DO 134 I=1,IDO + DO 133 K=1,L1 + CC(I,1,K) = CH(I,K,1) + 133 CONTINUE + 134 CONTINUE + 135 DO 137 J=2,IPPH + JC = IPP2-J + J2 = J+J + DO 136 K=1,L1 + CC(IDO,J2-2,K) = CH(1,K,J) + CC(1,J2-1,K) = CH(1,K,JC) + 136 CONTINUE + 137 CONTINUE + IF (IDO .EQ. 1) RETURN + IF (NBD .LT. L1) GO TO 141 + DO 140 J=2,IPPH + JC = IPP2-J + J2 = J+J + DO 139 K=1,L1 +CDIR$ IVDEP + DO 138 I=3,IDO,2 + IC = IDP2-I + CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) + CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) + CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) + CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) + 138 CONTINUE + 139 CONTINUE + 140 CONTINUE + RETURN + 141 DO 144 J=2,IPPH + JC = IPP2-J + J2 = J+J + DO 143 I=3,IDO,2 + IC = IDP2-I + DO 142 K=1,L1 + CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) + CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) + CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) + CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) + 142 CONTINUE + 143 CONTINUE + 144 CONTINUE + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rand.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rand.f new file mode 100644 index 0000000..22fb974 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rand.f @@ -0,0 +1,122 @@ +*DECK RAND + FUNCTION RAND (R) +C***BEGIN PROLOGUE RAND +C***PURPOSE Generate a uniformly distributed random number. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY L6A21 +C***TYPE SINGLE PRECISION (RAND-S) +C***KEYWORDS FNLIB, RANDOM NUMBER, SPECIAL FUNCTIONS, UNIFORM +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C This pseudo-random number generator is portable among a wide +C variety of computers. RAND(R) undoubtedly is not as good as many +C readily available installation dependent versions, and so this +C routine is not recommended for widespread usage. Its redeeming +C feature is that the exact same random numbers (to within final round- +C off error) can be generated from machine to machine. Thus, programs +C that make use of random numbers can be easily transported to and +C checked in a new environment. +C +C The random numbers are generated by the linear congruential +C method described, e.g., by Knuth in Seminumerical Methods (p.9), +C Addison-Wesley, 1969. Given the I-th number of a pseudo-random +C sequence, the I+1 -st number is generated from +C X(I+1) = (A*X(I) + C) MOD M, +C where here M = 2**22 = 4194304, C = 1731 and several suitable values +C of the multiplier A are discussed below. Both the multiplier A and +C random number X are represented in double precision as two 11-bit +C words. The constants are chosen so that the period is the maximum +C possible, 4194304. +C +C In order that the same numbers be generated from machine to +C machine, it is necessary that 23-bit integers be reducible modulo +C 2**11 exactly, that 23-bit integers be added exactly, and that 11-bit +C integers be multiplied exactly. Furthermore, if the restart option +C is used (where R is between 0 and 1), then the product R*2**22 = +C R*4194304 must be correct to the nearest integer. +C +C The first four random numbers should be .0004127026, +C .6750836372, .1614754200, and .9086198807. The tenth random number +C is .5527787209, and the hundredth is .3600893021 . The thousandth +C number should be .2176990509 . +C +C In order to generate several effectively independent sequences +C with the same generator, it is necessary to know the random number +C for several widely spaced calls. The I-th random number times 2**22, +C where I=K*P/8 and P is the period of the sequence (P = 2**22), is +C still of the form L*P/8. In particular we find the I-th random +C number multiplied by 2**22 is given by +C I = 0 1*P/8 2*P/8 3*P/8 4*P/8 5*P/8 6*P/8 7*P/8 8*P/8 +C RAND= 0 5*P/8 2*P/8 7*P/8 4*P/8 1*P/8 6*P/8 3*P/8 0 +C Thus the 4*P/8 = 2097152 random number is 2097152/2**22. +C +C Several multipliers have been subjected to the spectral test +C (see Knuth, p. 82). Four suitable multipliers roughly in order of +C goodness according to the spectral test are +C 3146757 = 1536*2048 + 1029 = 2**21 + 2**20 + 2**10 + 5 +C 2098181 = 1024*2048 + 1029 = 2**21 + 2**10 + 5 +C 3146245 = 1536*2048 + 517 = 2**21 + 2**20 + 2**9 + 5 +C 2776669 = 1355*2048 + 1629 = 5**9 + 7**7 + 1 +C +C In the table below LOG10(NU(I)) gives roughly the number of +C random decimal digits in the random numbers considered I at a time. +C C is the primary measure of goodness. In both cases bigger is better. +C +C LOG10 NU(I) C(I) +C A I=2 I=3 I=4 I=5 I=2 I=3 I=4 I=5 +C +C 3146757 3.3 2.0 1.6 1.3 3.1 1.3 4.6 2.6 +C 2098181 3.3 2.0 1.6 1.2 3.2 1.3 4.6 1.7 +C 3146245 3.3 2.2 1.5 1.1 3.2 4.2 1.1 0.4 +C 2776669 3.3 2.1 1.6 1.3 2.5 2.0 1.9 2.6 +C Best +C Possible 3.3 2.3 1.7 1.4 3.6 5.9 9.7 14.9 +C +C Input Argument -- +C R If R=0., the next random number of the sequence is generated. +C If R .LT. 0., the last generated number will be returned for +C possible use in a restart procedure. +C If R .GT. 0., the sequence of random numbers will start with +C the seed R mod 1. This seed is also returned as the value of +C RAND provided the arithmetic is done exactly. +C +C Output Value -- +C RAND a pseudo-random number between 0. and 1. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 770401 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE RAND + SAVE IA1, IA0, IA1MA0, IC, IX1, IX0 + DATA IA1, IA0, IA1MA0 /1536, 1029, 507/ + DATA IC /1731/ + DATA IX1, IX0 /0, 0/ +C***FIRST EXECUTABLE STATEMENT RAND + IF (R.LT.0.) GO TO 10 + IF (R.GT.0.) GO TO 20 +C +C A*X = 2**22*IA1*IX1 + 2**11*(IA1*IX1 + (IA1-IA0)*(IX0-IX1) +C + IA0*IX0) + IA0*IX0 +C + IY0 = IA0*IX0 + IY1 = IA1*IX1 + IA1MA0*(IX0-IX1) + IY0 + IY0 = IY0 + IC + IX0 = MOD (IY0, 2048) + IY1 = IY1 + (IY0-IX0)/2048 + IX1 = MOD (IY1, 2048) +C + 10 RAND = IX1*2048 + IX0 + RAND = RAND / 4194304. + RETURN +C + 20 IX1 = MOD(R,1.)*4194304. + 0.5 + IX0 = MOD (IX1, 2048) + IX1 = (IX1-IX0)/2048 + GO TO 10 +C + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rfftb1.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rfftb1.f new file mode 100644 index 0000000..c91fad7 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rfftb1.f @@ -0,0 +1,143 @@ +*DECK RFFTB1 + SUBROUTINE RFFTB1 (N, C, CH, WA, IFAC) +C***BEGIN PROLOGUE RFFTB1 +C***PURPOSE Compute the backward fast Fourier transform of a real +C coefficient array. +C***LIBRARY SLATEC (FFTPACK) +C***CATEGORY J1A1 +C***TYPE SINGLE PRECISION (RFFTB1-S, CFFTB1-C) +C***KEYWORDS FFTPACK, FOURIER TRANSFORM +C***AUTHOR Swarztrauber, P. N., (NCAR) +C***DESCRIPTION +C +C Subroutine RFFTB1 computes the real periodic sequence from its +C Fourier coefficients (Fourier synthesis). The transform is defined +C below at output parameter C. +C +C The arrays WA and IFAC which are used by subroutine RFFTB1 must be +C initialized by calling subroutine RFFTI1. +C +C Input Arguments +C +C N the length of the array R to be transformed. The method +C is most efficient when N is a product of small primes. +C N may change so long as different work arrays are provided. +C +C C a real array of length N which contains the sequence +C to be transformed. +C +C CH a real work array of length at least N. +C +C WA a real work array which must be dimensioned at least N. +C +C IFAC an integer work array which must be dimensioned at least 15. +C +C The WA and IFAC arrays must be initialized by calling +C subroutine RFFTI1, and different WA and IFAC arrays must be +C used for each different value of N. This initialization +C does not have to be repeated so long as N remains unchanged. +C Thus subsequent transforms can be obtained faster than the +C first. The same WA and IFAC arrays can be used by RFFTF1 +C and RFFTB1. +C +C Output Argument +C +C C For N even and for I = 1,...,N +C +C C(I) = C(1)+(-1)**(I-1)*C(N) +C +C plus the sum from K=2 to K=N/2 of +C +C 2.*C(2*K-2)*COS((K-1)*(I-1)*2*PI/N) +C +C -2.*C(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) +C +C For N odd and for I = 1,...,N +C +C C(I) = C(1) plus the sum from K=2 to K=(N+1)/2 of +C +C 2.*C(2*K-2)*COS((K-1)*(I-1)*2*PI/N) +C +C -2.*C(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) +C +C Notes: This transform is unnormalized since a call of RFFTF1 +C followed by a call of RFFTB1 will multiply the input +C sequence by N. +C +C WA and IFAC contain initialization calculations which must +C not be destroyed between calls of subroutine RFFTF1 or +C RFFTB1. +C +C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel +C Computations (G. Rodrigue, ed.), Academic Press, +C 1982, pp. 51-83. +C***ROUTINES CALLED RADB2, RADB3, RADB4, RADB5, RADBG +C***REVISION HISTORY (YYMMDD) +C 790601 DATE WRITTEN +C 830401 Modified to use SLATEC library source file format. +C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by +C changing dummy array size declarations (1) to (*). +C 881128 Modified by Dick Valent to meet prologue standards. +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900131 Routine changed from subsidiary to user-callable. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE RFFTB1 + DIMENSION CH(*), C(*), WA(*), IFAC(*) +C***FIRST EXECUTABLE STATEMENT RFFTB1 + NF = IFAC(2) + NA = 0 + L1 = 1 + IW = 1 + DO 116 K1=1,NF + IP = IFAC(K1+2) + L2 = IP*L1 + IDO = N/L2 + IDL1 = IDO*L1 + IF (IP .NE. 4) GO TO 103 + IX2 = IW+IDO + IX3 = IX2+IDO + IF (NA .NE. 0) GO TO 101 + CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) + GO TO 102 + 101 CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) + 102 NA = 1-NA + GO TO 115 + 103 IF (IP .NE. 2) GO TO 106 + IF (NA .NE. 0) GO TO 104 + CALL RADB2 (IDO,L1,C,CH,WA(IW)) + GO TO 105 + 104 CALL RADB2 (IDO,L1,CH,C,WA(IW)) + 105 NA = 1-NA + GO TO 115 + 106 IF (IP .NE. 3) GO TO 109 + IX2 = IW+IDO + IF (NA .NE. 0) GO TO 107 + CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2)) + GO TO 108 + 107 CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2)) + 108 NA = 1-NA + GO TO 115 + 109 IF (IP .NE. 5) GO TO 112 + IX2 = IW+IDO + IX3 = IX2+IDO + IX4 = IX3+IDO + IF (NA .NE. 0) GO TO 110 + CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) + GO TO 111 + 110 CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) + 111 NA = 1-NA + GO TO 115 + 112 IF (NA .NE. 0) GO TO 113 + CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) + GO TO 114 + 113 CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) + 114 IF (IDO .EQ. 1) NA = 1-NA + 115 L1 = L2 + IW = IW+(IP-1)*IDO + 116 CONTINUE + IF (NA .EQ. 0) RETURN + DO 117 I=1,N + C(I) = CH(I) + 117 CONTINUE + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rfftf1.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rfftf1.f new file mode 100644 index 0000000..e0e1910 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rfftf1.f @@ -0,0 +1,144 @@ +*DECK RFFTF1 + SUBROUTINE RFFTF1 (N, C, CH, WA, IFAC) +C***BEGIN PROLOGUE RFFTF1 +C***PURPOSE Compute the forward transform of a real, periodic sequence. +C***LIBRARY SLATEC (FFTPACK) +C***CATEGORY J1A1 +C***TYPE SINGLE PRECISION (RFFTF1-S, CFFTF1-C) +C***KEYWORDS FFTPACK, FOURIER TRANSFORM +C***AUTHOR Swarztrauber, P. N., (NCAR) +C***DESCRIPTION +C +C Subroutine RFFTF1 computes the Fourier coefficients of a real +C periodic sequence (Fourier analysis). The transform is defined +C below at output parameter C. +C +C The arrays WA and IFAC which are used by subroutine RFFTB1 must be +C initialized by calling subroutine RFFTI1. +C +C Input Arguments +C +C N the length of the array R to be transformed. The method +C is most efficient when N is a product of small primes. +C N may change so long as different work arrays are provided. +C +C C a real array of length N which contains the sequence +C to be transformed. +C +C CH a real work array of length at least N. +C +C WA a real work array which must be dimensioned at least N. +C +C IFAC an integer work array which must be dimensioned at least 15. +C +C The WA and IFAC arrays must be initialized by calling +C subroutine RFFTI1, and different WA and IFAC arrays must be +C used for each different value of N. This initialization +C does not have to be repeated so long as N remains unchanged. +C Thus subsequent transforms can be obtained faster than the +C first. The same WA and IFAC arrays can be used by RFFTF1 +C and RFFTB1. +C +C Output Argument +C +C C C(1) = the sum from I=1 to I=N of R(I) +C +C If N is even set L = N/2; if N is odd set L = (N+1)/2 +C +C then for K = 2,...,L +C +C C(2*K-2) = the sum from I = 1 to I = N of +C +C C(I)*COS((K-1)*(I-1)*2*PI/N) +C +C C(2*K-1) = the sum from I = 1 to I = N of +C +C -C(I)*SIN((K-1)*(I-1)*2*PI/N) +C +C If N is even +C +C C(N) = the sum from I = 1 to I = N of +C +C (-1)**(I-1)*C(I) +C +C Notes: This transform is unnormalized since a call of RFFTF1 +C followed by a call of RFFTB1 will multiply the input +C sequence by N. +C +C WA and IFAC contain initialization calculations which must +C not be destroyed between calls of subroutine RFFTF1 or +C RFFTB1. +C +C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel +C Computations (G. Rodrigue, ed.), Academic Press, +C 1982, pp. 51-83. +C***ROUTINES CALLED RADF2, RADF3, RADF4, RADF5, RADFG +C***REVISION HISTORY (YYMMDD) +C 790601 DATE WRITTEN +C 830401 Modified to use SLATEC library source file format. +C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by +C changing dummy array size declarations (1) to (*). +C 881128 Modified by Dick Valent to meet prologue standards. +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900131 Routine changed from subsidiary to user-callable. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE RFFTF1 + DIMENSION CH(*), C(*), WA(*), IFAC(*) +C***FIRST EXECUTABLE STATEMENT RFFTF1 + NF = IFAC(2) + NA = 1 + L2 = N + IW = N + DO 111 K1=1,NF + KH = NF-K1 + IP = IFAC(KH+3) + L1 = L2/IP + IDO = N/L2 + IDL1 = IDO*L1 + IW = IW-(IP-1)*IDO + NA = 1-NA + IF (IP .NE. 4) GO TO 102 + IX2 = IW+IDO + IX3 = IX2+IDO + IF (NA .NE. 0) GO TO 101 + CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) + GO TO 110 + 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) + GO TO 110 + 102 IF (IP .NE. 2) GO TO 104 + IF (NA .NE. 0) GO TO 103 + CALL RADF2 (IDO,L1,C,CH,WA(IW)) + GO TO 110 + 103 CALL RADF2 (IDO,L1,CH,C,WA(IW)) + GO TO 110 + 104 IF (IP .NE. 3) GO TO 106 + IX2 = IW+IDO + IF (NA .NE. 0) GO TO 105 + CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2)) + GO TO 110 + 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2)) + GO TO 110 + 106 IF (IP .NE. 5) GO TO 108 + IX2 = IW+IDO + IX3 = IX2+IDO + IX4 = IX3+IDO + IF (NA .NE. 0) GO TO 107 + CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) + GO TO 110 + 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) + GO TO 110 + 108 IF (IDO .EQ. 1) NA = 1-NA + IF (NA .NE. 0) GO TO 109 + CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) + NA = 1 + GO TO 110 + 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) + NA = 0 + 110 L2 = L1 + 111 CONTINUE + IF (NA .EQ. 1) RETURN + DO 112 I=1,N + C(I) = CH(I) + 112 CONTINUE + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rffti1.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rffti1.f new file mode 100644 index 0000000..8b82fba --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rffti1.f @@ -0,0 +1,110 @@ +*DECK RFFTI1 + SUBROUTINE RFFTI1 (N, WA, IFAC) +C***BEGIN PROLOGUE RFFTI1 +C***PURPOSE Initialize a real and an integer work array for RFFTF1 and +C RFFTB1. +C***LIBRARY SLATEC (FFTPACK) +C***CATEGORY J1A1 +C***TYPE SINGLE PRECISION (RFFTI1-S, CFFTI1-C) +C***KEYWORDS FFTPACK, FOURIER TRANSFORM +C***AUTHOR Swarztrauber, P. N., (NCAR) +C***DESCRIPTION +C +C Subroutine RFFTI1 initializes the work arrays WA and IFAC which are +C used in both RFFTF1 and RFFTB1. The prime factorization of N and a +C tabulation of the trigonometric functions are computed and stored in +C IFAC and WA, respectively. +C +C Input Argument +C +C N the length of the sequence to be transformed. +C +C Output Arguments +C +C WA a real work array which must be dimensioned at least N. +C +C IFAC an integer work array which must be dimensioned at least 15. +C +C The same work arrays can be used for both RFFTF1 and RFFTB1 as long +C as N remains unchanged. Different WA and IFAC arrays are required +C for different values of N. The contents of WA and IFAC must not be +C changed between calls of RFFTF1 or RFFTB1. +C +C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel +C Computations (G. Rodrigue, ed.), Academic Press, +C 1982, pp. 51-83. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790601 DATE WRITTEN +C 830401 Modified to use SLATEC library source file format. +C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by +C (a) changing dummy array size declarations (1) to (*), +C (b) changing references to intrinsic function FLOAT +C to REAL, and +C (c) changing definition of variable TPI by using +C FORTRAN intrinsic functions instead of DATA +C statements. +C 881128 Modified by Dick Valent to meet prologue standards. +C 890531 Changed all specific intrinsics to generic. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900131 Routine changed from subsidiary to user-callable. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE RFFTI1 + DIMENSION WA(*), IFAC(*), NTRYH(4) + SAVE NTRYH + DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ +C***FIRST EXECUTABLE STATEMENT RFFTI1 + NL = N + NF = 0 + J = 0 + 101 J = J+1 + IF (J-4) 102,102,103 + 102 NTRY = NTRYH(J) + GO TO 104 + 103 NTRY = NTRY+2 + 104 NQ = NL/NTRY + NR = NL-NTRY*NQ + IF (NR) 101,105,101 + 105 NF = NF+1 + IFAC(NF+2) = NTRY + NL = NQ + IF (NTRY .NE. 2) GO TO 107 + IF (NF .EQ. 1) GO TO 107 + DO 106 I=2,NF + IB = NF-I+2 + IFAC(IB+2) = IFAC(IB+1) + 106 CONTINUE + IFAC(3) = 2 + 107 IF (NL .NE. 1) GO TO 104 + IFAC(1) = N + IFAC(2) = NF + TPI = 8.*ATAN(1.) + ARGH = TPI/N + IS = 0 + NFM1 = NF-1 + L1 = 1 + IF (NFM1 .EQ. 0) RETURN + DO 110 K1=1,NFM1 + IP = IFAC(K1+2) + LD = 0 + L2 = L1*IP + IDO = N/L2 + IPM = IP-1 + DO 109 J=1,IPM + LD = LD+L1 + I = IS + ARGLD = LD*ARGH + FI = 0. + DO 108 II=3,IDO,2 + I = I+2 + FI = FI+1. + ARG = FI*ARGLD + WA(I-1) = COS(ARG) + WA(I) = SIN(ARG) + 108 CONTINUE + IS = IS+IDO + 109 CONTINUE + L1 = L2 + 110 CONTINUE + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rgauss.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rgauss.f new file mode 100644 index 0000000..5da63f5 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rgauss.f @@ -0,0 +1,43 @@ +*DECK RGAUSS + FUNCTION RGAUSS (XMEAN, SD) +C***BEGIN PROLOGUE RGAUSS +C***PURPOSE Generate a normally distributed (Gaussian) random number. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY L6A14 +C***TYPE SINGLE PRECISION (RGAUSS-S) +C***KEYWORDS FNLIB, GAUSSIAN, NORMAL, RANDOM NUMBER, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Generate a normally distributed random number, i.e., generate random +C numbers with a Gaussian distribution. These random numbers are not +C exceptionally good -- especially in the tails of the distribution, +C but this implementation is simple and suitable for most applications. +C See R. W. Hamming, Numerical Methods for Scientists and Engineers, +C McGraw-Hill, 1962, pages 34 and 389. +C +C Input Arguments -- +C XMEAN the mean of the Guassian distribution. +C SD the standard deviation of the Guassian function +C EXP (-1/2 * (X-XMEAN)**2 / SD**2) +C +C***REFERENCES (NONE) +C***ROUTINES CALLED RAND +C***REVISION HISTORY (YYMMDD) +C 770401 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 910819 Added EXTERNAL statement for RAND due to problem on IBM +C RS 6000. (WRB) +C***END PROLOGUE RGAUSS + EXTERNAL RAND +C***FIRST EXECUTABLE STATEMENT RGAUSS + RGAUSS = -6.0 + DO 10 I=1,12 + RGAUSS = RGAUSS + RAND(0.0) + 10 CONTINUE +C + RGAUSS = XMEAN + SD*RGAUSS +C + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rs.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rs.f new file mode 100644 index 0000000..1c6c56e --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rs.f @@ -0,0 +1,90 @@ +*DECK RS + SUBROUTINE RS (NM, N, A, W, MATZ, Z, FV1, FV2, IERR) +C***BEGIN PROLOGUE RS +C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors +C of a real symmetric matrix. +C***LIBRARY SLATEC (EISPACK) +C***CATEGORY D4A1 +C***TYPE SINGLE PRECISION (RS-S, CH-C) +C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK +C***AUTHOR Smith, B. T., et al. +C***DESCRIPTION +C +C This subroutine calls the recommended sequence of +C subroutines from the eigensystem subroutine package (EISPACK) +C to find the eigenvalues and eigenvectors (if desired) +C of a REAL SYMMETRIC matrix. +C +C On Input +C +C NM must be set to the row dimension of the two-dimensional +C array parameters, A and Z, as declared in the calling +C program dimension statement. NM is an INTEGER variable. +C +C N is the order of the matrix A. N is an INTEGER variable. +C N must be less than or equal to NM. +C +C A contains the real symmetric matrix. A is a two-dimensional +C REAL array, dimensioned A(NM,N). +C +C MATZ is an INTEGER variable set equal to zero if only +C eigenvalues are desired. Otherwise, it is set to any +C non-zero integer for both eigenvalues and eigenvectors. +C +C On Output +C +C A is unaltered. +C +C W contains the eigenvalues in ascending order. W is a one- +C dimensional REAL array, dimensioned W(N). +C +C Z contains the eigenvectors if MATZ is not zero. The +C eigenvectors are orthonormal. Z is a two-dimensional +C REAL array, dimensioned Z(NM,N). +C +C IERR is an INTEGER flag set to +C Zero for normal return, +C 10*N if N is greater than NM, +C J if the J-th eigenvalue has not been +C determined after 30 iterations. +C The eigenvalues, and eigenvectors if requested, +C should be correct for indices 1, 2, ..., IERR-1. +C +C FV1 and FV2 are one-dimensional REAL arrays used for temporary +C storage, dimensioned FV1(N) and FV2(N). +C +C Questions and comments should be directed to B. S. Garbow, +C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +C ------------------------------------------------------------------ +C +C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, +C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- +C system Routines - EISPACK Guide, Springer-Verlag, +C 1976. +C***ROUTINES CALLED TQL2, TQLRAT, TRED1, TRED2 +C***REVISION HISTORY (YYMMDD) +C 760101 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE RS +C + INTEGER N,NM,IERR,MATZ + REAL A(NM,*),W(*),Z(NM,*),FV1(*),FV2(*) +C +C***FIRST EXECUTABLE STATEMENT RS + IF (N .LE. NM) GO TO 10 + IERR = 10 * N + GO TO 50 +C + 10 IF (MATZ .NE. 0) GO TO 20 +C .......... FIND EIGENVALUES ONLY .......... + CALL TRED1(NM,N,A,W,FV1,FV2) + CALL TQLRAT(N,W,FV2,IERR) + GO TO 50 +C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... + 20 CALL TRED2(NM,N,A,W,FV1,Z) + CALL TQL2(NM,N,W,FV1,Z,IERR) + 50 RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rwupdt.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rwupdt.f new file mode 100644 index 0000000..08164c5 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/rwupdt.f @@ -0,0 +1,120 @@ +*DECK RWUPDT + SUBROUTINE RWUPDT (N, R, LDR, W, B, ALPHA, COS, SIN) +C***BEGIN PROLOGUE RWUPDT +C***SUBSIDIARY +C***PURPOSE Subsidiary to SNLS1 and SNLS1E +C***LIBRARY SLATEC +C***TYPE SINGLE PRECISION (RWUPDT-S, DWUPDT-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C Given an N by N upper triangular matrix R, this subroutine +C computes the QR decomposition of the matrix formed when a row +C is added to R. If the row is specified by the vector W, then +C RWUPDT determines an orthogonal matrix Q such that when the +C N+1 by N matrix composed of R augmented by W is premultiplied +C by (Q TRANSPOSE), the resulting matrix is upper trapezoidal. +C The orthogonal matrix Q is the product of N transformations +C +C G(1)*G(2)* ... *G(N) +C +C where G(I) is a Givens rotation in the (I,N+1) plane which +C eliminates elements in the I-th plane. RWUPDT also +C computes the product (Q TRANSPOSE)*C where C is the +C (N+1)-vector (b,alpha). Q itself is not accumulated, rather +C the information to recover the G rotations is supplied. +C +C The subroutine statement is +C +C SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN) +C +C where +C +C N is a positive integer input variable set to the order of R. +C +C R is an N by N array. On input the upper triangular part of +C R must contain the matrix to be updated. On output R +C contains the updated triangular matrix. +C +C LDR is a positive integer input variable not less than N +C which specifies the leading dimension of the array R. +C +C W is an input array of length N which must contain the row +C vector to be added to R. +C +C B is an array of length N. On input B must contain the +C first N elements of the vector C. On output B contains +C the first N elements of the vector (Q TRANSPOSE)*C. +C +C ALPHA is a variable. On input ALPHA must contain the +C (N+1)-st element of the vector C. On output ALPHA contains +C the (N+1)-st element of the vector (Q TRANSPOSE)*C. +C +C COS is an output array of length N which contains the +C cosines of the transforming Givens rotations. +C +C SIN is an output array of length N which contains the +C sines of the transforming Givens rotations. +C +C***SEE ALSO SNLS1, SNLS1E +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 800301 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 900328 Added TYPE section. (WRB) +C***END PROLOGUE RWUPDT + INTEGER N,LDR + REAL ALPHA + REAL R(LDR,*),W(*),B(*),COS(*),SIN(*) + INTEGER I,J,JM1 + REAL COTAN,ONE,P5,P25,ROWJ,TAN,TEMP,ZERO + SAVE ONE, P5, P25, ZERO + DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/ +C***FIRST EXECUTABLE STATEMENT RWUPDT + DO 60 J = 1, N + ROWJ = W(J) + JM1 = J - 1 +C +C APPLY THE PREVIOUS TRANSFORMATIONS TO +C R(I,J), I=1,2,...,J-1, AND TO W(J). +C + IF (JM1 .LT. 1) GO TO 20 + DO 10 I = 1, JM1 + TEMP = COS(I)*R(I,J) + SIN(I)*ROWJ + ROWJ = -SIN(I)*R(I,J) + COS(I)*ROWJ + R(I,J) = TEMP + 10 CONTINUE + 20 CONTINUE +C +C DETERMINE A GIVENS ROTATION WHICH ELIMINATES W(J). +C + COS(J) = ONE + SIN(J) = ZERO + IF (ROWJ .EQ. ZERO) GO TO 50 + IF (ABS(R(J,J)) .GE. ABS(ROWJ)) GO TO 30 + COTAN = R(J,J)/ROWJ + SIN(J) = P5/SQRT(P25+P25*COTAN**2) + COS(J) = SIN(J)*COTAN + GO TO 40 + 30 CONTINUE + TAN = ROWJ/R(J,J) + COS(J) = P5/SQRT(P25+P25*TAN**2) + SIN(J) = COS(J)*TAN + 40 CONTINUE +C +C APPLY THE CURRENT TRANSFORMATION TO R(J,J), B(J), AND ALPHA. +C + R(J,J) = COS(J)*R(J,J) + SIN(J)*ROWJ + TEMP = COS(J)*B(J) + SIN(J)*ALPHA + ALPHA = -SIN(J)*B(J) + COS(J)*ALPHA + B(J) = TEMP + 50 CONTINUE + 60 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE RWUPDT. +C + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/snls1.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/snls1.f new file mode 100644 index 0000000..122822d --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/snls1.f @@ -0,0 +1,1023 @@ +*DECK SNLS1 + SUBROUTINE SNLS1 (FCN, IOPT, M, N, X, FVEC, FJAC, LDFJAC, FTOL, + + XTOL, GTOL, MAXFEV, EPSFCN, DIAG, MODE, FACTOR, NPRINT, INFO, + + NFEV, NJEV, IPVT, QTF, WA1, WA2, WA3, WA4) +C***BEGIN PROLOGUE SNLS1 +C***PURPOSE Minimize the sum of the squares of M nonlinear functions +C in N variables by a modification of the Levenberg-Marquardt +C algorithm. +C***LIBRARY SLATEC +C***CATEGORY K1B1A1, K1B1A2 +C***TYPE SINGLE PRECISION (SNLS1-S, DNLS1-D) +C***KEYWORDS LEVENBERG-MARQUARDT, NONLINEAR DATA FITTING, +C NONLINEAR LEAST SQUARES +C***AUTHOR Hiebert, K. L., (SNLA) +C***DESCRIPTION +C +C 1. Purpose. +C +C The purpose of SNLS1 is to minimize the sum of the squares of M +C nonlinear functions in N variables by a modification of the +C Levenberg-Marquardt algorithm. The user must provide a subrou- +C tine which calculates the functions. The user has the option +C of how the Jacobian will be supplied. The user can supply the +C full Jacobian, or the rows of the Jacobian (to avoid storing +C the full Jacobian), or let the code approximate the Jacobian by +C forward-differencing. This code is the combination of the +C MINPACK codes (Argonne) LMDER, LMDIF, and LMSTR. +C +C +C 2. Subroutine and Type Statements. +C +C SUBROUTINE SNLS1(FCN,IOPT,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL, +C * GTOL,MAXFEV,EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO +C * ,NFEV,NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) +C INTEGER IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV +C INTEGER IPVT(N) +C REAL FTOL,XTOL,GTOL,EPSFCN,FACTOR +C REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), +C * WA1(N),WA2(N),WA3(N),WA4(M) +C +C +C 3. Parameters. +C +C Parameters designated as input parameters must be specified on +C entry to SNLS1 and are not changed on exit, while parameters +C designated as output parameters need not be specified on entry +C and are set to appropriate values on exit from SNLS1. +C +C FCN is the name of the user-supplied subroutine which calculates +C the functions. If the user wants to supply the Jacobian +C (IOPT=2 or 3), then FCN must be written to calculate the +C Jacobian, as well as the functions. See the explanation +C of the IOPT argument below. +C If the user wants the iterates printed (NPRINT positive), then +C FCN must do the printing. See the explanation of NPRINT +C below. FCN must be declared in an EXTERNAL statement in the +C calling program and should be written as follows. +C +C +C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) +C INTEGER IFLAG,LDFJAC,M,N +C REAL X(N),FVEC(M) +C ---------- +C FJAC and LDFJAC may be ignored , if IOPT=1. +C REAL FJAC(LDFJAC,N) , if IOPT=2. +C REAL FJAC(N) , if IOPT=3. +C ---------- +C If IFLAG=0, the values in X and FVEC are available +C for printing. See the explanation of NPRINT below. +C IFLAG will never be zero unless NPRINT is positive. +C The values of X and FVEC must not be changed. +C RETURN +C ---------- +C If IFLAG=1, calculate the functions at X and return +C this vector in FVEC. +C RETURN +C ---------- +C If IFLAG=2, calculate the full Jacobian at X and return +C this matrix in FJAC. Note that IFLAG will never be 2 unless +C IOPT=2. FVEC contains the function values at X and must +C not be altered. FJAC(I,J) must be set to the derivative +C of FVEC(I) with respect to X(J). +C RETURN +C ---------- +C If IFLAG=3, calculate the LDFJAC-th row of the Jacobian +C and return this vector in FJAC. Note that IFLAG will +C never be 3 unless IOPT=3. FVEC contains the function +C values at X and must not be altered. FJAC(J) must be +C set to the derivative of FVEC(LDFJAC) with respect to X(J). +C RETURN +C ---------- +C END +C +C +C The value of IFLAG should not be changed by FCN unless the +C user wants to terminate execution of SNLS1. In this case, set +C IFLAG to a negative integer. +C +C +C IOPT is an input variable which specifies how the Jacobian will +C be calculated. If IOPT=2 or 3, then the user must supply the +C Jacobian, as well as the function values, through the +C subroutine FCN. If IOPT=2, the user supplies the full +C Jacobian with one call to FCN. If IOPT=3, the user supplies +C one row of the Jacobian with each call. (In this manner, +C storage can be saved because the full Jacobian is not stored.) +C If IOPT=1, the code will approximate the Jacobian by forward +C differencing. +C +C M is a positive integer input variable set to the number of +C functions. +C +C N is a positive integer input variable set to the number of +C variables. N must not exceed M. +C +C X is an array of length N. On input, X must contain an initial +C estimate of the solution vector. On output, X contains the +C final estimate of the solution vector. +C +C FVEC is an output array of length M which contains the functions +C evaluated at the output X. +C +C FJAC is an output array. For IOPT=1 and 2, FJAC is an M by N +C array. For IOPT=3, FJAC is an N by N array. The upper N by N +C submatrix of FJAC contains an upper triangular matrix R with +C diagonal elements of nonincreasing magnitude such that +C +C T T T +C P *(JAC *JAC)*P = R *R, +C +C where P is a permutation matrix and JAC is the final calcu- +C lated Jacobian. Column J of P is column IPVT(J) (see below) +C of the identity matrix. The lower part of FJAC contains +C information generated during the computation of R. +C +C LDFJAC is a positive integer input variable which specifies +C the leading dimension of the array FJAC. For IOPT=1 and 2, +C LDFJAC must not be less than M. For IOPT=3, LDFJAC must not +C be less than N. +C +C FTOL is a non-negative input variable. Termination occurs when +C both the actual and predicted relative reductions in the sum +C of squares are at most FTOL. Therefore, FTOL measures the +C relative error desired in the sum of squares. Section 4 con- +C tains more details about FTOL. +C +C XTOL is a non-negative input variable. Termination occurs when +C the relative error between two consecutive iterates is at most +C XTOL. Therefore, XTOL measures the relative error desired in +C the approximate solution. Section 4 contains more details +C about XTOL. +C +C GTOL is a non-negative input variable. Termination occurs when +C the cosine of the angle between FVEC and any column of the +C Jacobian is at most GTOL in absolute value. Therefore, GTOL +C measures the orthogonality desired between the function vector +C and the columns of the Jacobian. Section 4 contains more +C details about GTOL. +C +C MAXFEV is a positive integer input variable. Termination occurs +C when the number of calls to FCN to evaluate the functions +C has reached MAXFEV. +C +C EPSFCN is an input variable used in determining a suitable step +C for the forward-difference approximation. This approximation +C assumes that the relative errors in the functions are of the +C order of EPSFCN. If EPSFCN is less than the machine preci- +C sion, it is assumed that the relative errors in the functions +C are of the order of the machine precision. If IOPT=2 or 3, +C then EPSFCN can be ignored (treat it as a dummy argument). +C +C DIAG is an array of length N. If MODE = 1 (see below), DIAG is +C internally set. If MODE = 2, DIAG must contain positive +C entries that serve as implicit (multiplicative) scale factors +C for the variables. +C +C MODE is an integer input variable. If MODE = 1, the variables +C will be scaled internally. If MODE = 2, the scaling is speci- +C fied by the input DIAG. Other values of MODE are equivalent +C to MODE = 1. +C +C FACTOR is a positive input variable used in determining the ini- +C tial step bound. This bound is set to the product of FACTOR +C and the Euclidean norm of DIAG*X if nonzero, or else to FACTOR +C itself. In most cases FACTOR should lie in the interval +C (.1,100.). 100. is a generally recommended value. +C +C NPRINT is an integer input variable that enables controlled +C printing of iterates if it is positive. In this case, FCN is +C called with IFLAG = 0 at the beginning of the first iteration +C and every NPRINT iterations thereafter and immediately prior +C to return, with X and FVEC available for printing. Appropriate +C print statements must be added to FCN (see example) and +C FVEC should not be altered. If NPRINT is not positive, no +C special calls to FCN with IFLAG = 0 are made. +C +C INFO is an integer output variable. If the user has terminated +C execution, INFO is set to the (negative) value of IFLAG. See +C description of FCN and JAC. Otherwise, INFO is set as follows. +C +C INFO = 0 improper input parameters. +C +C INFO = 1 both actual and predicted relative reductions in the +C sum of squares are at most FTOL. +C +C INFO = 2 relative error between two consecutive iterates is +C at most XTOL. +C +C INFO = 3 conditions for INFO = 1 and INFO = 2 both hold. +C +C INFO = 4 the cosine of the angle between FVEC and any column +C of the Jacobian is at most GTOL in absolute value. +C +C INFO = 5 number of calls to FCN for function evaluation +C has reached MAXFEV. +C +C INFO = 6 FTOL is too small. No further reduction in the sum +C of squares is possible. +C +C INFO = 7 XTOL is too small. No further improvement in the +C approximate solution X is possible. +C +C INFO = 8 GTOL is too small. FVEC is orthogonal to the +C columns of the Jacobian to machine precision. +C +C Sections 4 and 5 contain more details about INFO. +C +C NFEV is an integer output variable set to the number of calls to +C FCN for function evaluation. +C +C NJEV is an integer output variable set to the number of +C evaluations of the full Jacobian. If IOPT=2, only one call to +C FCN is required for each evaluation of the full Jacobian. +C If IOPT=3, the M calls to FCN are required. +C If IOPT=1, then NJEV is set to zero. +C +C IPVT is an integer output array of length N. IPVT defines a +C permutation matrix P such that JAC*P = Q*R, where JAC is the +C final calculated Jacobian, Q is orthogonal (not stored), and R +C is upper triangular with diagonal elements of nonincreasing +C magnitude. Column J of P is column IPVT(J) of the identity +C matrix. +C +C QTF is an output array of length N which contains the first N +C elements of the vector (Q transpose)*FVEC. +C +C WA1, WA2, and WA3 are work arrays of length N. +C +C WA4 is a work array of length M. +C +C +C 4. Successful Completion. +C +C The accuracy of SNLS1 is controlled by the convergence parame- +C ters FTOL, XTOL, and GTOL. These parameters are used in tests +C which make three types of comparisons between the approximation +C X and a solution XSOL. SNLS1 terminates when any of the tests +C is satisfied. If any of the convergence parameters is less than +C the machine precision (as defined by the function R1MACH(4)), +C then SNLS1 only attempts to satisfy the test defined by the +C machine precision. Further progress is not usually possible. +C +C The tests assume that the functions are reasonably well behaved, +C and, if the Jacobian is supplied by the user, that the functions +C and the Jacobian are coded consistently. If these conditions +C are not satisfied, then SNLS1 may incorrectly indicate conver- +C gence. If the Jacobian is coded correctly or IOPT=1, +C then the validity of the answer can be checked, for example, by +C rerunning SNLS1 with tighter tolerances. +C +C First Convergence Test. If ENORM(Z) denotes the Euclidean norm +C of a vector Z, then this test attempts to guarantee that +C +C ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), +C +C where FVECS denotes the functions evaluated at XSOL. If this +C condition is satisfied with FTOL = 10**(-K), then the final +C residual norm ENORM(FVEC) has K significant decimal digits and +C INFO is set to 1 (or to 3 if the second test is also satis- +C fied). Unless high precision solutions are required, the +C recommended value for FTOL is the square root of the machine +C precision. +C +C Second Convergence Test. If D is the diagonal matrix whose +C entries are defined by the array DIAG, then this test attempts +C to guarantee that +C +C ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). +C +C If this condition is satisfied with XTOL = 10**(-K), then the +C larger components of D*X have K significant decimal digits and +C INFO is set to 2 (or to 3 if the first test is also satis- +C fied). There is a danger that the smaller components of D*X +C may have large relative errors, but if MODE = 1, then the +C accuracy of the components of X is usually related to their +C sensitivity. Unless high precision solutions are required, +C the recommended value for XTOL is the square root of the +C machine precision. +C +C Third Convergence Test. This test is satisfied when the cosine +C of the angle between FVEC and any column of the Jacobian at X +C is at most GTOL in absolute value. There is no clear rela- +C tionship between this test and the accuracy of SNLS1, and +C furthermore, the test is equally well satisfied at other crit- +C ical points, namely maximizers and saddle points. Therefore, +C termination caused by this test (INFO = 4) should be examined +C carefully. The recommended value for GTOL is zero. +C +C +C 5. Unsuccessful Completion. +C +C Unsuccessful termination of SNLS1 can be due to improper input +C parameters, arithmetic interrupts, or an excessive number of +C function evaluations. +C +C Improper Input Parameters. INFO is set to 0 if IOPT .LT. 1 +C or IOPT .GT. 3, or N .LE. 0, or M .LT. N, or for IOPT=1 or 2 +C LDFJAC .LT. M, or for IOPT=3 LDFJAC .LT. N, or FTOL .LT. 0.E0, +C or XTOL .LT. 0.E0, or GTOL .LT. 0.E0, or MAXFEV .LE. 0, or +C FACTOR .LE. 0.E0. +C +C Arithmetic Interrupts. If these interrupts occur in the FCN +C subroutine during an early stage of the computation, they may +C be caused by an unacceptable choice of X by SNLS1. In this +C case, it may be possible to remedy the situation by rerunning +C SNLS1 with a smaller value of FACTOR. +C +C Excessive Number of Function Evaluations. A reasonable value +C for MAXFEV is 100*(N+1) for IOPT=2 or 3 and 200*(N+1) for +C IOPT=1. If the number of calls to FCN reaches MAXFEV, then +C this indicates that the routine is converging very slowly +C as measured by the progress of FVEC, and INFO is set to 5. +C In this case, it may be helpful to restart SNLS1 with MODE +C set to 1. +C +C +C 6. Characteristics of the Algorithm. +C +C SNLS1 is a modification of the Levenberg-Marquardt algorithm. +C Two of its main characteristics involve the proper use of +C implicitly scaled variables (if MODE = 1) and an optimal choice +C for the correction. The use of implicitly scaled variables +C achieves scale invariance of SNLS1 and limits the size of the +C correction in any direction where the functions are changing +C rapidly. The optimal choice of the correction guarantees (under +C reasonable conditions) global convergence from starting points +C far from the solution and a fast rate of convergence for +C problems with small residuals. +C +C Timing. The time required by SNLS1 to solve a given problem +C depends on M and N, the behavior of the functions, the accu- +C racy requested, and the starting point. The number of arith- +C metic operations needed by SNLS1 is about N**3 to process each +C evaluation of the functions (call to FCN) and to process each +C evaluation of the Jacobian it takes M*N**2 for IOPT=2 (one +C call to FCN), M*N**2 for IOPT=1 (N calls to FCN) and +C 1.5*M*N**2 for IOPT=3 (M calls to FCN). Unless FCN +C can be evaluated quickly, the timing of SNLS1 will be +C strongly influenced by the time spent in FCN. +C +C Storage. SNLS1 requires (M*N + 2*M + 6*N) for IOPT=1 or 2 and +C (N**2 + 2*M + 6*N) for IOPT=3 single precision storage +C locations and N integer storage locations, in addition to +C the storage required by the program. There are no internally +C declared storage arrays. +C +C *Long Description: +C +C 7. Example. +C +C The problem is to determine the values of X(1), X(2), and X(3) +C which provide the best fit (in the least squares sense) of +C +C X(1) + U(I)/(V(I)*X(2) + W(I)*X(3)), I = 1, 15 +C +C to the data +C +C Y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, +C 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +C +C where U(I) = I, V(I) = 16 - I, and W(I) = MIN(U(I),V(I)). The +C I-th component of FVEC is thus defined by +C +C Y(I) - (X(1) + U(I)/(V(I)*X(2) + W(I)*X(3))). +C +C ********** +C +C PROGRAM TEST +C C +C C Driver for SNLS1 example. +C C +C INTEGER J,IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV, +C * NWRITE +C INTEGER IPVT(3) +C REAL FTOL,XTOL,GTOL,FACTOR,FNORM,EPSFCN +C REAL X(3),FVEC(15),FJAC(15,3),DIAG(3),QTF(3), +C * WA1(3),WA2(3),WA3(3),WA4(15) +C REAL ENORM,R1MACH +C EXTERNAL FCN +C DATA NWRITE /6/ +C C +C IOPT = 1 +C M = 15 +C N = 3 +C C +C C The following starting values provide a rough fit. +C C +C X(1) = 1.E0 +C X(2) = 1.E0 +C X(3) = 1.E0 +C C +C LDFJAC = 15 +C C +C C Set FTOL and XTOL to the square root of the machine precision +C C and GTOL to zero. Unless high precision solutions are +C C required, these are the recommended settings. +C C +C FTOL = SQRT(R1MACH(4)) +C XTOL = SQRT(R1MACH(4)) +C GTOL = 0.E0 +C C +C MAXFEV = 400 +C EPSFCN = 0.0 +C MODE = 1 +C FACTOR = 1.E2 +C NPRINT = 0 +C C +C CALL SNLS1(FCN,IOPT,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL, +C * GTOL,MAXFEV,EPSFCN,DIAG,MODE,FACTOR,NPRINT, +C * INFO,NFEV,NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) +C FNORM = ENORM(M,FVEC) +C WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) +C STOP +C 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // +C * 5X,' NUMBER OF FUNCTION EVALUATIONS',I10 // +C * 5X,' NUMBER OF JACOBIAN EVALUATIONS',I10 // +C * 5X,' EXIT PARAMETER',16X,I10 // +C * 5X,' FINAL APPROXIMATE SOLUTION' // 5X,3E15.7) +C END +C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,DUM,IDUM) +C C This is the form of the FCN routine if IOPT=1, +C C that is, if the user does not calculate the Jacobian. +C INTEGER M,N,IFLAG +C REAL X(N),FVEC(M) +C INTEGER I +C REAL TMP1,TMP2,TMP3,TMP4 +C REAL Y(15) +C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), +C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) +C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, +C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ +C C +C IF (IFLAG .NE. 0) GO TO 5 +C C +C C Insert print statements here when NPRINT is positive. +C C +C RETURN +C 5 CONTINUE +C DO 10 I = 1, M +C TMP1 = I +C TMP2 = 16 - I +C TMP3 = TMP1 +C IF (I .GT. 8) TMP3 = TMP2 +C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) +C 10 CONTINUE +C RETURN +C END +C +C +C Results obtained with different compilers or machines +C may be slightly different. +C +C FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 +C +C NUMBER OF FUNCTION EVALUATIONS 25 +C +C NUMBER OF JACOBIAN EVALUATIONS 0 +C +C EXIT PARAMETER 1 +C +C FINAL APPROXIMATE SOLUTION +C +C 0.8241058E-01 0.1133037E+01 0.2343695E+01 +C +C +C For IOPT=2, FCN would be modified as follows to also +C calculate the full Jacobian when IFLAG=2. +C +C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) +C C +C C This is the form of the FCN routine if IOPT=2, +C C that is, if the user calculates the full Jacobian. +C C +C INTEGER LDFJAC,M,N,IFLAG +C REAL X(N),FVEC(M) +C REAL FJAC(LDFJAC,N) +C INTEGER I +C REAL TMP1,TMP2,TMP3,TMP4 +C REAL Y(15) +C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), +C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) +C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, +C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ +C C +C IF (IFLAG .NE. 0) GO TO 5 +C C +C C Insert print statements here when NPRINT is positive. +C C +C RETURN +C 5 CONTINUE +C IF(IFLAG.NE.1) GO TO 20 +C DO 10 I = 1, M +C TMP1 = I +C TMP2 = 16 - I +C TMP3 = TMP1 +C IF (I .GT. 8) TMP3 = TMP2 +C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) +C 10 CONTINUE +C RETURN +C C +C C Below, calculate the full Jacobian. +C C +C 20 CONTINUE +C C +C DO 30 I = 1, M +C TMP1 = I +C TMP2 = 16 - I +C TMP3 = TMP1 +C IF (I .GT. 8) TMP3 = TMP2 +C TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 +C FJAC(I,1) = -1.E0 +C FJAC(I,2) = TMP1*TMP2/TMP4 +C FJAC(I,3) = TMP1*TMP3/TMP4 +C 30 CONTINUE +C RETURN +C END +C +C +C For IOPT = 3, FJAC would be dimensioned as FJAC(3,3), +C LDFJAC would be set to 3, and FCN would be written as +C follows to calculate a row of the Jacobian when IFLAG=3. +C +C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) +C C This is the form of the FCN routine if IOPT=3, +C C that is, if the user calculates the Jacobian row by row. +C INTEGER M,N,IFLAG +C REAL X(N),FVEC(M) +C REAL FJAC(N) +C INTEGER I +C REAL TMP1,TMP2,TMP3,TMP4 +C REAL Y(15) +C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), +C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) +C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, +C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ +C C +C IF (IFLAG .NE. 0) GO TO 5 +C C +C C Insert print statements here when NPRINT is positive. +C C +C RETURN +C 5 CONTINUE +C IF( IFLAG.NE.1) GO TO 20 +C DO 10 I = 1, M +C TMP1 = I +C TMP2 = 16 - I +C TMP3 = TMP1 +C IF (I .GT. 8) TMP3 = TMP2 +C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) +C 10 CONTINUE +C RETURN +C C +C C Below, calculate the LDFJAC-th row of the Jacobian. +C C +C 20 CONTINUE +C +C I = LDFJAC +C TMP1 = I +C TMP2 = 16 - I +C TMP3 = TMP1 +C IF (I .GT. 8) TMP3 = TMP2 +C TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 +C FJAC(1) = -1.E0 +C FJAC(2) = TMP1*TMP2/TMP4 +C FJAC(3) = TMP1*TMP3/TMP4 +C RETURN +C END +C +C***REFERENCES Jorge J. More, The Levenberg-Marquardt algorithm: +C implementation and theory. In Numerical Analysis +C Proceedings (Dundee, June 28 - July 1, 1977, G. A. +C Watson, Editor), Lecture Notes in Mathematics 630, +C Springer-Verlag, 1978. +C***ROUTINES CALLED CHKDER, ENORM, FDJAC3, LMPAR, QRFAC, R1MACH, +C RWUPDT, XERMSG +C***REVISION HISTORY (YYMMDD) +C 800301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900510 Convert XERRWV calls to XERMSG calls. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE SNLS1 + INTEGER IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV + INTEGER IJUNK,NROW,IPVT(*) + REAL FTOL,XTOL,GTOL,FACTOR,EPSFCN + REAL X(*),FVEC(*),FJAC(LDFJAC,*),DIAG(*),QTF(*),WA1(*),WA2(*), + 1 WA3(*),WA4(*) + LOGICAL SING + EXTERNAL FCN + INTEGER I,IFLAG,ITER,J,L,MODECH + REAL ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,ONE,PAR, + 1 PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP,TEMP1, + 2 TEMP2,XNORM,ZERO + REAL R1MACH,ENORM,ERR,CHKLIM + CHARACTER*8 XERN1 + CHARACTER*16 XERN3 +C + SAVE CHKLIM, ONE, P1, P5, P25, P75, P0001, ZERO + DATA CHKLIM/.1E0/ + DATA ONE,P1,P5,P25,P75,P0001,ZERO + 1 /1.0E0,1.0E-1,5.0E-1,2.5E-1,7.5E-1,1.0E-4,0.0E0/ +C +C***FIRST EXECUTABLE STATEMENT SNLS1 + EPSMCH = R1MACH(4) +C + INFO = 0 + IFLAG = 0 + NFEV = 0 + NJEV = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (IOPT .LT. 1 .OR. IOPT .GT. 3 .OR. N .LE. 0 .OR. + 1 M .LT. N .OR. LDFJAC .LT. N .OR. FTOL .LT. ZERO + 2 .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO + 3 .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300 + IF (IOPT .LT. 3 .AND. LDFJAC .LT. M) GO TO 300 + IF (MODE .NE. 2) GO TO 20 + DO 10 J = 1, N + IF (DIAG(J) .LE. ZERO) GO TO 300 + 10 CONTINUE + 20 CONTINUE +C +C EVALUATE THE FUNCTION AT THE STARTING POINT +C AND CALCULATE ITS NORM. +C + IFLAG = 1 + IJUNK = 1 + CALL FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) + NFEV = 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM = ENORM(M,FVEC) +C +C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. +C + PAR = ZERO + ITER = 1 +C +C BEGINNING OF THE OUTER LOOP. +C + 30 CONTINUE +C +C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. +C + IF (NPRINT .LE. 0) GO TO 40 + IFLAG = 0 + IF (MOD(ITER-1,NPRINT) .EQ. 0) + 1 CALL FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) + IF (IFLAG .LT. 0) GO TO 300 + 40 CONTINUE +C +C CALCULATE THE JACOBIAN MATRIX. +C + IF (IOPT .EQ. 3) GO TO 475 +C +C STORE THE FULL JACOBIAN USING M*N STORAGE +C + IF (IOPT .EQ. 1) GO TO 410 +C +C THE USER SUPPLIES THE JACOBIAN +C + IFLAG = 2 + CALL FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) + NJEV = NJEV + 1 +C +C ON THE FIRST ITERATION, CHECK THE USER SUPPLIED JACOBIAN +C + IF (ITER .LE. 1) THEN + IF (IFLAG .LT. 0) GO TO 300 +C +C GET THE INCREMENTED X-VALUES INTO WA1(*). +C + MODECH = 1 + CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,WA1,WA4,MODECH,ERR) +C +C EVALUATE FUNCTION AT INCREMENTED VALUE AND PUT IN WA4(*). +C + IFLAG = 1 + CALL FCN(IFLAG,M,N,WA1,WA4,FJAC,LDFJAC) + NFEV = NFEV + 1 + IF(IFLAG .LT. 0) GO TO 300 + DO 350 I = 1, M + MODECH = 2 + CALL CHKDER(1,N,X,FVEC(I),FJAC(I,1),LDFJAC,WA1, + 1 WA4(I),MODECH,ERR) + IF (ERR .LT. CHKLIM) THEN + WRITE (XERN1, '(I8)') I + WRITE (XERN3, '(1PE15.6)') ERR + CALL XERMSG ('SLATEC', 'SNLS1', 'DERIVATIVE OF ' // + * 'FUNCTION ' // XERN1 // ' MAY BE WRONG, ERR = ' // + * XERN3 // ' TOO CLOSE TO 0.', 7, 0) + ENDIF + 350 CONTINUE + ENDIF +C + GO TO 420 +C +C THE CODE APPROXIMATES THE JACOBIAN +C +410 IFLAG = 1 + CALL FDJAC3(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4) + NFEV = NFEV + N + 420 IF (IFLAG .LT. 0) GO TO 300 +C +C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. +C + CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) +C +C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN +C QTF. +C + DO 430 I = 1, M + WA4(I) = FVEC(I) + 430 CONTINUE + DO 470 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) GO TO 460 + SUM = ZERO + DO 440 I = J, M + SUM = SUM + FJAC(I,J)*WA4(I) + 440 CONTINUE + TEMP = -SUM/FJAC(J,J) + DO 450 I = J, M + WA4(I) = WA4(I) + FJAC(I,J)*TEMP + 450 CONTINUE + 460 CONTINUE + FJAC(J,J) = WA1(J) + QTF(J) = WA4(J) + 470 CONTINUE + GO TO 560 +C +C ACCUMULATE THE JACOBIAN BY ROWS IN ORDER TO SAVE STORAGE. +C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX +C CALCULATED ONE ROW AT A TIME, WHILE SIMULTANEOUSLY +C FORMING (Q TRANSPOSE)*FVEC AND STORING THE FIRST +C N COMPONENTS IN QTF. +C + 475 DO 490 J = 1, N + QTF(J) = ZERO + DO 480 I = 1, N + FJAC(I,J) = ZERO + 480 CONTINUE + 490 CONTINUE + DO 500 I = 1, M + NROW = I + IFLAG = 3 + CALL FCN(IFLAG,M,N,X,FVEC,WA3,NROW) + IF (IFLAG .LT. 0) GO TO 300 +C +C ON THE FIRST ITERATION, CHECK THE USER SUPPLIED JACOBIAN. +C + IF(ITER .GT. 1) GO TO 498 +C +C GET THE INCREMENTED X-VALUES INTO WA1(*). +C + MODECH = 1 + CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,WA1,WA4,MODECH,ERR) +C +C EVALUATE AT INCREMENTED VALUES, IF NOT ALREADY EVALUATED. +C + IF(I .NE. 1) GO TO 495 +C +C EVALUATE FUNCTION AT INCREMENTED VALUE AND PUT INTO WA4(*). +C + IFLAG = 1 + CALL FCN(IFLAG,M,N,WA1,WA4,FJAC,NROW) + NFEV = NFEV + 1 + IF(IFLAG .LT. 0) GO TO 300 +495 CONTINUE + MODECH = 2 + CALL CHKDER(1,N,X,FVEC(I),WA3,1,WA1,WA4(I),MODECH,ERR) + IF (ERR .LT. CHKLIM) THEN + WRITE (XERN1, '(I8)') I + WRITE (XERN3, '(1PE15.6)') ERR + CALL XERMSG ('SLATEC', 'SNLS1', 'DERIVATIVE OF FUNCTION ' + * // XERN1 // ' MAY BE WRONG, ERR = ' // XERN3 // + * ' TOO CLOSE TO 0.', 7, 0) + ENDIF +498 CONTINUE +C + TEMP = FVEC(I) + CALL RWUPDT(N,FJAC,LDFJAC,WA3,QTF,TEMP,WA1,WA2) + 500 CONTINUE + NJEV = NJEV + 1 +C +C IF THE JACOBIAN IS RANK DEFICIENT, CALL QRFAC TO +C REORDER ITS COLUMNS AND UPDATE THE COMPONENTS OF QTF. +C + SING = .FALSE. + DO 510 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) SING = .TRUE. + IPVT(J) = J + WA2(J) = ENORM(J,FJAC(1,J)) + 510 CONTINUE + IF (.NOT.SING) GO TO 560 + CALL QRFAC(N,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) + DO 550 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) GO TO 540 + SUM = ZERO + DO 520 I = J, N + SUM = SUM + FJAC(I,J)*QTF(I) + 520 CONTINUE + TEMP = -SUM/FJAC(J,J) + DO 530 I = J, N + QTF(I) = QTF(I) + FJAC(I,J)*TEMP + 530 CONTINUE + 540 CONTINUE + FJAC(J,J) = WA1(J) + 550 CONTINUE + 560 CONTINUE +C +C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING +C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. +C + IF (ITER .NE. 1) GO TO 80 + IF (MODE .EQ. 2) GO TO 60 + DO 50 J = 1, N + DIAG(J) = WA2(J) + IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE + 50 CONTINUE + 60 CONTINUE +C +C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X +C AND INITIALIZE THE STEP BOUND DELTA. +C + DO 70 J = 1, N + WA3(J) = DIAG(J)*X(J) + 70 CONTINUE + XNORM = ENORM(N,WA3) + DELTA = FACTOR*XNORM + IF (DELTA .EQ. ZERO) DELTA = FACTOR + 80 CONTINUE +C +C COMPUTE THE NORM OF THE SCALED GRADIENT. +C + GNORM = ZERO + IF (FNORM .EQ. ZERO) GO TO 170 + DO 160 J = 1, N + L = IPVT(J) + IF (WA2(L) .EQ. ZERO) GO TO 150 + SUM = ZERO + DO 140 I = 1, J + SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) + 140 CONTINUE + GNORM = MAX(GNORM,ABS(SUM/WA2(L))) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE +C +C TEST FOR CONVERGENCE OF THE GRADIENT NORM. +C + IF (GNORM .LE. GTOL) INFO = 4 + IF (INFO .NE. 0) GO TO 300 +C +C RESCALE IF NECESSARY. +C + IF (MODE .EQ. 2) GO TO 190 + DO 180 J = 1, N + DIAG(J) = MAX(DIAG(J),WA2(J)) + 180 CONTINUE + 190 CONTINUE +C +C BEGINNING OF THE INNER LOOP. +C + 200 CONTINUE +C +C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. +C + CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, + 1 WA3,WA4) +C +C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. +C + DO 210 J = 1, N + WA1(J) = -WA1(J) + WA2(J) = X(J) + WA1(J) + WA3(J) = DIAG(J)*WA1(J) + 210 CONTINUE + PNORM = ENORM(N,WA3) +C +C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. +C + IF (ITER .EQ. 1) DELTA = MIN(DELTA,PNORM) +C +C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(IFLAG,M,N,WA2,WA4,FJAC,IJUNK) + NFEV = NFEV + 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM1 = ENORM(M,WA4) +C +C COMPUTE THE SCALED ACTUAL REDUCTION. +C + ACTRED = -ONE + IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 +C +C COMPUTE THE SCALED PREDICTED REDUCTION AND +C THE SCALED DIRECTIONAL DERIVATIVE. +C + DO 230 J = 1, N + WA3(J) = ZERO + L = IPVT(J) + TEMP = WA1(L) + DO 220 I = 1, J + WA3(I) = WA3(I) + FJAC(I,J)*TEMP + 220 CONTINUE + 230 CONTINUE + TEMP1 = ENORM(N,WA3)/FNORM + TEMP2 = (SQRT(PAR)*PNORM)/FNORM + PRERED = TEMP1**2 + TEMP2**2/P5 + DIRDER = -(TEMP1**2 + TEMP2**2) +C +C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED +C REDUCTION. +C + RATIO = ZERO + IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED +C +C UPDATE THE STEP BOUND. +C + IF (RATIO .GT. P25) GO TO 240 + IF (ACTRED .GE. ZERO) TEMP = P5 + IF (ACTRED .LT. ZERO) + 1 TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) + IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 + DELTA = TEMP*MIN(DELTA,PNORM/P1) + PAR = PAR/TEMP + GO TO 260 + 240 CONTINUE + IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250 + DELTA = PNORM/P5 + PAR = P5*PAR + 250 CONTINUE + 260 CONTINUE +C +C TEST FOR SUCCESSFUL ITERATION. +C + IF (RATIO .LT. P0001) GO TO 290 +C +C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. +C + DO 270 J = 1, N + X(J) = WA2(J) + WA2(J) = DIAG(J)*X(J) + 270 CONTINUE + DO 280 I = 1, M + FVEC(I) = WA4(I) + 280 CONTINUE + XNORM = ENORM(N,WA2) + FNORM = FNORM1 + ITER = ITER + 1 + 290 CONTINUE +C +C TESTS FOR CONVERGENCE. +C + IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL + 1 .AND. P5*RATIO .LE. ONE) INFO = 1 + IF (DELTA .LE. XTOL*XNORM) INFO = 2 + IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL + 1 .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 + IF (INFO .NE. 0) GO TO 300 +C +C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. +C + IF (NFEV .GE. MAXFEV) INFO = 5 + IF (ABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH + 1 .AND. P5*RATIO .LE. ONE) INFO = 6 + IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 + IF (GNORM .LE. EPSMCH) INFO = 8 + IF (INFO .NE. 0) GO TO 300 +C +C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. +C + IF (RATIO .LT. P0001) GO TO 200 +C +C END OF THE OUTER LOOP. +C + GO TO 30 + 300 CONTINUE +C +C TERMINATION, EITHER NORMAL OR USER IMPOSED. +C + IF (IFLAG .LT. 0) INFO = IFLAG + IFLAG = 0 + IF (NPRINT .GT. 0) CALL FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) + IF (INFO .LT. 0) CALL XERMSG ('SLATEC', 'SNLS1', + + 'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1) + IF (INFO .EQ. 0) CALL XERMSG ('SLATEC', 'SNLS1', + + 'INVALID INPUT PARAMETER.', 2, 1) + IF (INFO .EQ. 4) CALL XERMSG ('SLATEC', 'SNLS1', + + 'THIRD CONVERGENCE CONDITION, CHECK RESULTS BEFORE ACCEPTING.', + + 1, 1) + IF (INFO .EQ. 5) CALL XERMSG ('SLATEC', 'SNLS1', + + 'TOO MANY FUNCTION EVALUATIONS.', 9, 1) + IF (INFO .GE. 6) CALL XERMSG ('SLATEC', 'SNLS1', + + 'TOLERANCES TOO SMALL, NO FURTHER IMPROVEMENT POSSIBLE.', 3, 1) + RETURN +C +C LAST CARD OF SUBROUTINE SNLS1. +C + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tql2.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tql2.f new file mode 100644 index 0000000..40d9938 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tql2.f @@ -0,0 +1,203 @@ +*DECK TQL2 + SUBROUTINE TQL2 (NM, N, D, E, Z, IERR) +C***BEGIN PROLOGUE TQL2 +C***PURPOSE Compute the eigenvalues and eigenvectors of symmetric +C tridiagonal matrix. +C***LIBRARY SLATEC (EISPACK) +C***CATEGORY D4A5, D4C2A +C***TYPE SINGLE PRECISION (TQL2-S) +C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK +C***AUTHOR Smith, B. T., et al. +C***DESCRIPTION +C +C This subroutine is a translation of the ALGOL procedure TQL2, +C NUM. MATH. 11, 293-306(1968) by Bowdler, Martin, Reinsch, and +C Wilkinson. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). +C +C This subroutine finds the eigenvalues and eigenvectors +C of a SYMMETRIC TRIDIAGONAL matrix by the QL method. +C The eigenvectors of a FULL SYMMETRIC matrix can also +C be found if TRED2 has been used to reduce this +C full matrix to tridiagonal form. +C +C On Input +C +C NM must be set to the row dimension of the two-dimensional +C array parameter, Z, as declared in the calling program +C dimension statement. NM is an INTEGER variable. +C +C N is the order of the matrix. N is an INTEGER variable. +C N must be less than or equal to NM. +C +C D contains the diagonal elements of the symmetric tridiagonal +C matrix. D is a one-dimensional REAL array, dimensioned D(N). +C +C E contains the subdiagonal elements of the symmetric +C tridiagonal matrix in its last N-1 positions. E(1) is +C arbitrary. E is a one-dimensional REAL array, dimensioned +C E(N). +C +C Z contains the transformation matrix produced in the +C reduction by TRED2, if performed. If the eigenvectors +C of the tridiagonal matrix are desired, Z must contain +C the identity matrix. Z is a two-dimensional REAL array, +C dimensioned Z(NM,N). +C +C On Output +C +C D contains the eigenvalues in ascending order. If an +C error exit is made, the eigenvalues are correct but +C unordered for indices 1, 2, ..., IERR-1. +C +C E has been destroyed. +C +C Z contains orthonormal eigenvectors of the symmetric +C tridiagonal (or full) matrix. If an error exit is made, +C Z contains the eigenvectors associated with the stored +C eigenvalues. +C +C IERR is an INTEGER flag set to +C Zero for normal return, +C J if the J-th eigenvalue has not been +C determined after 30 iterations. +C +C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). +C +C Questions and comments should be directed to B. S. Garbow, +C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +C ------------------------------------------------------------------ +C +C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, +C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- +C system Routines - EISPACK Guide, Springer-Verlag, +C 1976. +C***ROUTINES CALLED PYTHAG +C***REVISION HISTORY (YYMMDD) +C 760101 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE TQL2 +C + INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR + REAL D(*),E(*),Z(NM,*) + REAL B,C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2 + REAL PYTHAG +C +C***FIRST EXECUTABLE STATEMENT TQL2 + IERR = 0 + IF (N .EQ. 1) GO TO 1001 +C + DO 100 I = 2, N + 100 E(I-1) = E(I) +C + F = 0.0E0 + B = 0.0E0 + E(N) = 0.0E0 +C + DO 240 L = 1, N + J = 0 + H = ABS(D(L)) + ABS(E(L)) + IF (B .LT. H) B = H +C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... + DO 110 M = L, N + IF (B + ABS(E(M)) .EQ. B) GO TO 120 +C .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT +C THROUGH THE BOTTOM OF THE LOOP .......... + 110 CONTINUE +C + 120 IF (M .EQ. L) GO TO 220 + 130 IF (J .EQ. 30) GO TO 1000 + J = J + 1 +C .......... FORM SHIFT .......... + L1 = L + 1 + L2 = L1 + 1 + G = D(L) + P = (D(L1) - G) / (2.0E0 * E(L)) + R = PYTHAG(P,1.0E0) + D(L) = E(L) / (P + SIGN(R,P)) + D(L1) = E(L) * (P + SIGN(R,P)) + DL1 = D(L1) + H = G - D(L) + IF (L2 .GT. N) GO TO 145 +C + DO 140 I = L2, N + 140 D(I) = D(I) - H +C + 145 F = F + H +C .......... QL TRANSFORMATION .......... + P = D(M) + C = 1.0E0 + C2 = C + EL1 = E(L1) + S = 0.0E0 + MML = M - L +C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... + DO 200 II = 1, MML + C3 = C2 + C2 = C + S2 = S + I = M - II + G = C * E(I) + H = C * P + IF (ABS(P) .LT. ABS(E(I))) GO TO 150 + C = E(I) / P + R = SQRT(C*C+1.0E0) + E(I+1) = S * P * R + S = C / R + C = 1.0E0 / R + GO TO 160 + 150 C = P / E(I) + R = SQRT(C*C+1.0E0) + E(I+1) = S * E(I) * R + S = 1.0E0 / R + C = C * S + 160 P = C * D(I) - S * G + D(I+1) = H + S * (C * G + S * D(I)) +C .......... FORM VECTOR .......... + DO 180 K = 1, N + H = Z(K,I+1) + Z(K,I+1) = S * Z(K,I) + C * H + Z(K,I) = C * Z(K,I) - S * H + 180 CONTINUE +C + 200 CONTINUE +C + P = -S * S2 * C3 * EL1 * E(L) / DL1 + E(L) = S * P + D(L) = C * P + IF (B + ABS(E(L)) .GT. B) GO TO 130 + 220 D(L) = D(L) + F + 240 CONTINUE +C .......... ORDER EIGENVALUES AND EIGENVECTORS .......... + DO 300 II = 2, N + I = II - 1 + K = I + P = D(I) +C + DO 260 J = II, N + IF (D(J) .GE. P) GO TO 260 + K = J + P = D(J) + 260 CONTINUE +C + IF (K .EQ. I) GO TO 300 + D(K) = D(I) + D(I) = P +C + DO 280 J = 1, N + P = Z(J,I) + Z(J,I) = Z(J,K) + Z(J,K) = P + 280 CONTINUE +C + 300 CONTINUE +C + GO TO 1001 +C .......... SET ERROR -- NO CONVERGENCE TO AN +C EIGENVALUE AFTER 30 ITERATIONS .......... + 1000 IERR = L + 1001 RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tqlrat.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tqlrat.f new file mode 100644 index 0000000..8cb7b9c --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tqlrat.f @@ -0,0 +1,165 @@ +*DECK TQLRAT + SUBROUTINE TQLRAT (N, D, E2, IERR) +C***BEGIN PROLOGUE TQLRAT +C***PURPOSE Compute the eigenvalues of symmetric tridiagonal matrix +C using a rational variant of the QL method. +C***LIBRARY SLATEC (EISPACK) +C***CATEGORY D4A5, D4C2A +C***TYPE SINGLE PRECISION (TQLRAT-S) +C***KEYWORDS EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX, EISPACK, +C QL METHOD +C***AUTHOR Smith, B. T., et al. +C***DESCRIPTION +C +C This subroutine is a translation of the ALGOL procedure TQLRAT. +C +C This subroutine finds the eigenvalues of a SYMMETRIC +C TRIDIAGONAL matrix by the rational QL method. +C +C On Input +C +C N is the order of the matrix. N is an INTEGER variable. +C +C D contains the diagonal elements of the symmetric tridiagonal +C matrix. D is a one-dimensional REAL array, dimensioned D(N). +C +C E2 contains the squares of the subdiagonal elements of the +C symmetric tridiagonal matrix in its last N-1 positions. +C E2(1) is arbitrary. E2 is a one-dimensional REAL array, +C dimensioned E2(N). +C +C On Output +C +C D contains the eigenvalues in ascending order. If an +C error exit is made, the eigenvalues are correct and +C ordered for indices 1, 2, ..., IERR-1, but may not be +C the smallest eigenvalues. +C +C E2 has been destroyed. +C +C IERR is an INTEGER flag set to +C Zero for normal return, +C J if the J-th eigenvalue has not been +C determined after 30 iterations. +C +C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). +C +C Questions and comments should be directed to B. S. Garbow, +C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +C ------------------------------------------------------------------ +C +C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, +C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- +C system Routines - EISPACK Guide, Springer-Verlag, +C 1976. +C C. H. Reinsch, Eigenvalues of a real, symmetric, tri- +C diagonal matrix, Algorithm 464, Communications of the +C ACM 16, 11 (November 1973), pp. 689. +C***ROUTINES CALLED PYTHAG, R1MACH +C***REVISION HISTORY (YYMMDD) +C 760101 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE TQLRAT +C + INTEGER I,J,L,M,N,II,L1,MML,IERR + REAL D(*),E2(*) + REAL B,C,F,G,H,P,R,S,MACHEP + REAL PYTHAG + LOGICAL FIRST +C + SAVE FIRST, MACHEP + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT TQLRAT + IF (FIRST) THEN + MACHEP = R1MACH(4) + ENDIF + FIRST = .FALSE. +C + IERR = 0 + IF (N .EQ. 1) GO TO 1001 +C + DO 100 I = 2, N + 100 E2(I-1) = E2(I) +C + F = 0.0E0 + B = 0.0E0 + E2(N) = 0.0E0 +C + DO 290 L = 1, N + J = 0 + H = MACHEP * (ABS(D(L)) + SQRT(E2(L))) + IF (B .GT. H) GO TO 105 + B = H + C = B * B +C .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT .......... + 105 DO 110 M = L, N + IF (E2(M) .LE. C) GO TO 120 +C .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT +C THROUGH THE BOTTOM OF THE LOOP .......... + 110 CONTINUE +C + 120 IF (M .EQ. L) GO TO 210 + 130 IF (J .EQ. 30) GO TO 1000 + J = J + 1 +C .......... FORM SHIFT .......... + L1 = L + 1 + S = SQRT(E2(L)) + G = D(L) + P = (D(L1) - G) / (2.0E0 * S) + R = PYTHAG(P,1.0E0) + D(L) = S / (P + SIGN(R,P)) + H = G - D(L) +C + DO 140 I = L1, N + 140 D(I) = D(I) - H +C + F = F + H +C .......... RATIONAL QL TRANSFORMATION .......... + G = D(M) + IF (G .EQ. 0.0E0) G = B + H = G + S = 0.0E0 + MML = M - L +C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... + DO 200 II = 1, MML + I = M - II + P = G * H + R = P + E2(I) + E2(I+1) = S * R + S = E2(I) / R + D(I+1) = H + S * (H + D(I)) + G = D(I) - E2(I) / G + IF (G .EQ. 0.0E0) G = B + H = G * P / R + 200 CONTINUE +C + E2(L) = S * G + D(L) = H +C .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST .......... + IF (H .EQ. 0.0E0) GO TO 210 + IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210 + E2(L) = H * E2(L) + IF (E2(L) .NE. 0.0E0) GO TO 130 + 210 P = D(L) + F +C .......... ORDER EIGENVALUES .......... + IF (L .EQ. 1) GO TO 250 +C .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... + DO 230 II = 2, L + I = L + 2 - II + IF (P .GE. D(I-1)) GO TO 270 + D(I) = D(I-1) + 230 CONTINUE +C + 250 I = 1 + 270 D(I) = P + 290 CONTINUE +C + GO TO 1001 +C .......... SET ERROR -- NO CONVERGENCE TO AN +C EIGENVALUE AFTER 30 ITERATIONS .......... + 1000 IERR = L + 1001 RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tred1.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tred1.f new file mode 100644 index 0000000..1586bd5 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tred1.f @@ -0,0 +1,142 @@ +*DECK TRED1 + SUBROUTINE TRED1 (NM, N, A, D, E, E2) +C***BEGIN PROLOGUE TRED1 +C***PURPOSE Reduce a real symmetric matrix to symmetric tridiagonal +C matrix using orthogonal similarity transformations. +C***LIBRARY SLATEC (EISPACK) +C***CATEGORY D4C1B1 +C***TYPE SINGLE PRECISION (TRED1-S) +C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK +C***AUTHOR Smith, B. T., et al. +C***DESCRIPTION +C +C This subroutine is a translation of the ALGOL procedure TRED1, +C NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). +C +C This subroutine reduces a REAL SYMMETRIC matrix +C to a symmetric tridiagonal matrix using +C orthogonal similarity transformations. +C +C On Input +C +C NM must be set to the row dimension of the two-dimensional +C array parameter, A, as declared in the calling program +C dimension statement. NM is an INTEGER variable. +C +C N is the order of the matrix A. N is an INTEGER variable. +C N must be less than or equal to NM. +C +C A contains the real symmetric input matrix. Only the lower +C triangle of the matrix need be supplied. A is a two- +C dimensional REAL array, dimensioned A(NM,N). +C +C On Output +C +C A contains information about the orthogonal transformations +C used in the reduction in its strict lower triangle. The +C full upper triangle of A is unaltered. +C +C D contains the diagonal elements of the symmetric tridiagonal +C matrix. D is a one-dimensional REAL array, dimensioned D(N). +C +C E contains the subdiagonal elements of the symmetric +C tridiagonal matrix in its last N-1 positions. E(1) is set +C to zero. E is a one-dimensional REAL array, dimensioned +C E(N). +C +C E2 contains the squares of the corresponding elements of E. +C E2 may coincide with E if the squares are not needed. +C E2 is a one-dimensional REAL array, dimensioned E2(N). +C +C Questions and comments should be directed to B. S. Garbow, +C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +C ------------------------------------------------------------------ +C +C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, +C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- +C system Routines - EISPACK Guide, Springer-Verlag, +C 1976. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 760101 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE TRED1 +C + INTEGER I,J,K,L,N,II,NM,JP1 + REAL A(NM,*),D(*),E(*),E2(*) + REAL F,G,H,SCALE +C +C***FIRST EXECUTABLE STATEMENT TRED1 + DO 100 I = 1, N + 100 D(I) = A(I,I) +C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... + DO 300 II = 1, N + I = N + 1 - II + L = I - 1 + H = 0.0E0 + SCALE = 0.0E0 + IF (L .LT. 1) GO TO 130 +C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... + DO 120 K = 1, L + 120 SCALE = SCALE + ABS(A(I,K)) +C + IF (SCALE .NE. 0.0E0) GO TO 140 + 130 E(I) = 0.0E0 + E2(I) = 0.0E0 + GO TO 290 +C + 140 DO 150 K = 1, L + A(I,K) = A(I,K) / SCALE + H = H + A(I,K) * A(I,K) + 150 CONTINUE +C + E2(I) = SCALE * SCALE * H + F = A(I,L) + G = -SIGN(SQRT(H),F) + E(I) = SCALE * G + H = H - F * G + A(I,L) = F - G + IF (L .EQ. 1) GO TO 270 + F = 0.0E0 +C + DO 240 J = 1, L + G = 0.0E0 +C .......... FORM ELEMENT OF A*U .......... + DO 180 K = 1, J + 180 G = G + A(J,K) * A(I,K) +C + JP1 = J + 1 + IF (L .LT. JP1) GO TO 220 +C + DO 200 K = JP1, L + 200 G = G + A(K,J) * A(I,K) +C .......... FORM ELEMENT OF P .......... + 220 E(J) = G / H + F = F + E(J) * A(I,J) + 240 CONTINUE +C + H = F / (H + H) +C .......... FORM REDUCED A .......... + DO 260 J = 1, L + F = A(I,J) + G = E(J) - H * F + E(J) = G +C + DO 260 K = 1, J + A(J,K) = A(J,K) - F * E(K) - G * A(I,K) + 260 CONTINUE +C + 270 DO 280 K = 1, L + 280 A(I,K) = SCALE * A(I,K) +C + 290 H = D(I) + D(I) = A(I,I) + A(I,I) = H + 300 CONTINUE +C + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tred2.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tred2.f new file mode 100644 index 0000000..6b52c32 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/tred2.f @@ -0,0 +1,166 @@ +*DECK TRED2 + SUBROUTINE TRED2 (NM, N, A, D, E, Z) +C***BEGIN PROLOGUE TRED2 +C***PURPOSE Reduce a real symmetric matrix to a symmetric tridiagonal +C matrix using and accumulating orthogonal transformations. +C***LIBRARY SLATEC (EISPACK) +C***CATEGORY D4C1B1 +C***TYPE SINGLE PRECISION (TRED2-S) +C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK +C***AUTHOR Smith, B. T., et al. +C***DESCRIPTION +C +C This subroutine is a translation of the ALGOL procedure TRED2, +C NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). +C +C This subroutine reduces a REAL SYMMETRIC matrix to a +C symmetric tridiagonal matrix using and accumulating +C orthogonal similarity transformations. +C +C On Input +C +C NM must be set to the row dimension of the two-dimensional +C array parameters, A and Z, as declared in the calling +C program dimension statement. NM is an INTEGER variable. +C +C N is the order of the matrix A. N is an INTEGER variable. +C N must be less than or equal to NM. +C +C A contains the real symmetric input matrix. Only the lower +C triangle of the matrix need be supplied. A is a two- +C dimensional REAL array, dimensioned A(NM,N). +C +C On Output +C +C D contains the diagonal elements of the symmetric tridiagonal +C matrix. D is a one-dimensional REAL array, dimensioned D(N). +C +C E contains the subdiagonal elements of the symmetric +C tridiagonal matrix in its last N-1 positions. E(1) is set +C to zero. E is a one-dimensional REAL array, dimensioned +C E(N). +C +C Z contains the orthogonal transformation matrix produced in +C the reduction. Z is a two-dimensional REAL array, +C dimensioned Z(NM,N). +C +C A and Z may coincide. If distinct, A is unaltered. +C +C Questions and comments should be directed to B. S. Garbow, +C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +C ------------------------------------------------------------------ +C +C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, +C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- +C system Routines - EISPACK Guide, Springer-Verlag, +C 1976. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 760101 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE TRED2 +C + INTEGER I,J,K,L,N,II,NM,JP1 + REAL A(NM,*),D(*),E(*),Z(NM,*) + REAL F,G,H,HH,SCALE +C +C***FIRST EXECUTABLE STATEMENT TRED2 + DO 100 I = 1, N +C + DO 100 J = 1, I + Z(I,J) = A(I,J) + 100 CONTINUE +C + IF (N .EQ. 1) GO TO 320 +C .......... FOR I=N STEP -1 UNTIL 2 DO -- .......... + DO 300 II = 2, N + I = N + 2 - II + L = I - 1 + H = 0.0E0 + SCALE = 0.0E0 + IF (L .LT. 2) GO TO 130 +C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... + DO 120 K = 1, L + 120 SCALE = SCALE + ABS(Z(I,K)) +C + IF (SCALE .NE. 0.0E0) GO TO 140 + 130 E(I) = Z(I,L) + GO TO 290 +C + 140 DO 150 K = 1, L + Z(I,K) = Z(I,K) / SCALE + H = H + Z(I,K) * Z(I,K) + 150 CONTINUE +C + F = Z(I,L) + G = -SIGN(SQRT(H),F) + E(I) = SCALE * G + H = H - F * G + Z(I,L) = F - G + F = 0.0E0 +C + DO 240 J = 1, L + Z(J,I) = Z(I,J) / H + G = 0.0E0 +C .......... FORM ELEMENT OF A*U .......... + DO 180 K = 1, J + 180 G = G + Z(J,K) * Z(I,K) +C + JP1 = J + 1 + IF (L .LT. JP1) GO TO 220 +C + DO 200 K = JP1, L + 200 G = G + Z(K,J) * Z(I,K) +C .......... FORM ELEMENT OF P .......... + 220 E(J) = G / H + F = F + E(J) * Z(I,J) + 240 CONTINUE +C + HH = F / (H + H) +C .......... FORM REDUCED A .......... + DO 260 J = 1, L + F = Z(I,J) + G = E(J) - HH * F + E(J) = G +C + DO 260 K = 1, J + Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K) + 260 CONTINUE +C + 290 D(I) = H + 300 CONTINUE +C + 320 D(1) = 0.0E0 + E(1) = 0.0E0 +C .......... ACCUMULATION OF TRANSFORMATION MATRICES .......... + DO 500 I = 1, N + L = I - 1 + IF (D(I) .EQ. 0.0E0) GO TO 380 +C + DO 360 J = 1, L + G = 0.0E0 +C + DO 340 K = 1, L + 340 G = G + Z(I,K) * Z(K,J) +C + DO 360 K = 1, L + Z(K,J) = Z(K,J) - G * Z(K,I) + 360 CONTINUE +C + 380 D(I) = Z(I,I) + Z(I,I) = 1.0E0 + IF (L .LT. 1) GO TO 500 +C + DO 400 J = 1, L + Z(I,J) = 0.0E0 + Z(J,I) = 0.0E0 + 400 CONTINUE +C + 500 CONTINUE +C + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xercnt.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xercnt.f new file mode 100644 index 0000000..2338632 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xercnt.f @@ -0,0 +1,62 @@ +*DECK XERCNT +c changed by setting KONTRL=0 + SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL) +C***BEGIN PROLOGUE XERCNT +C***SUBSIDIARY +C***PURPOSE Allow user control over handling of errors. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERCNT-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C Allows user control over handling of individual errors. +C Just after each message is recorded, but before it is +C processed any further (i.e., before it is printed or +C a decision to abort is made), a call is made to XERCNT. +C If the user has provided his own version of XERCNT, he +C can then override the value of KONTROL used in processing +C this message by redefining its value. +C KONTRL may be set to any value from -2 to 2. +C The meanings for KONTRL are the same as in XSETF, except +C that the value of KONTRL changes only for this message. +C If KONTRL is set to a value outside the range from -2 to 2, +C it will be moved back into that range. +C +C Description of Parameters +C +C --Input-- +C LIBRAR - the library that the routine is in. +C SUBROU - the subroutine that XERMSG is being called from +C MESSG - the first 20 characters of the error message. +C NERR - same as in the call to XERMSG. +C LEVEL - same as in the call to XERMSG. +C KONTRL - the current value of the control flag as set +C by a call to XSETF. +C +C --Output-- +C KONTRL - the new value of KONTRL. If KONTRL is not +C defined, it will remain at its original value. +C This changed value of control affects only +C the current occurrence of the current message. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900206 Routine changed from user-callable to subsidiary. (WRB) +C 900510 Changed calling sequence to include LIBRARY and SUBROUTINE +C names, changed routine name from XERCTL to XERCNT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERCNT + CHARACTER*(*) LIBRAR, SUBROU, MESSG +C***FIRST EXECUTABLE STATEMENT XERCNT + KONTRL=0 + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xerhlt.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xerhlt.f new file mode 100644 index 0000000..89b2a77 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xerhlt.f @@ -0,0 +1,39 @@ +*DECK XERHLT + SUBROUTINE XERHLT (MESSG) +C***BEGIN PROLOGUE XERHLT +C***SUBSIDIARY +C***PURPOSE Abort program execution and print error message. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERHLT-A) +C***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C ***Note*** machine dependent routine +C XERHLT aborts the execution of the program. +C The error message causing the abort is given in the calling +C sequence, in case one needs it for printing on a dayfile, +C for example. +C +C Description of Parameters +C MESSG is as in XERMSG. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900206 Routine changed from user-callable to subsidiary. (WRB) +C 900510 Changed calling sequence to delete length of character +C and changed routine name from XERABT to XERHLT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERHLT + CHARACTER*(*) MESSG +C***FIRST EXECUTABLE STATEMENT XERHLT + STOP + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xermsg.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xermsg.f new file mode 100644 index 0000000..46c83ec --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xermsg.f @@ -0,0 +1,364 @@ +*DECK XERMSG + SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) +C***BEGIN PROLOGUE XERMSG +C***PURPOSE Process error messages for SLATEC and other libraries. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERMSG-A) +C***KEYWORDS ERROR MESSAGE, XERROR +C***AUTHOR Fong, Kirby, (NMFECC at LLNL) +C***DESCRIPTION +C +C XERMSG processes a diagnostic message in a manner determined by the +C value of LEVEL and the current value of the library error control +C flag, KONTRL. See subroutine XSETF for details. +C +C LIBRAR A character constant (or character variable) with the name +C of the library. This will be 'SLATEC' for the SLATEC +C Common Math Library. The error handling package is +C general enough to be used by many libraries +C simultaneously, so it is desirable for the routine that +C detects and reports an error to identify the library name +C as well as the routine name. +C +C SUBROU A character constant (or character variable) with the name +C of the routine that detected the error. Usually it is the +C name of the routine that is calling XERMSG. There are +C some instances where a user callable library routine calls +C lower level subsidiary routines where the error is +C detected. In such cases it may be more informative to +C supply the name of the routine the user called rather than +C the name of the subsidiary routine that detected the +C error. +C +C MESSG A character constant (or character variable) with the text +C of the error or warning message. In the example below, +C the message is a character constant that contains a +C generic message. +C +C CALL XERMSG ('SLATEC', 'MMPY', +C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', +C *3, 1) +C +C It is possible (and is sometimes desirable) to generate a +C specific message--e.g., one that contains actual numeric +C values. Specific numeric values can be converted into +C character strings using formatted WRITE statements into +C character variables. This is called standard Fortran +C internal file I/O and is exemplified in the first three +C lines of the following example. You can also catenate +C substrings of characters to construct the error message. +C Here is an example showing the use of both writing to +C an internal file and catenating character strings. +C +C CHARACTER*5 CHARN, CHARL +C WRITE (CHARN,10) N +C WRITE (CHARL,10) LDA +C 10 FORMAT(I5) +C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// +C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// +C * CHARL, 3, 1) +C +C There are two subtleties worth mentioning. One is that +C the // for character catenation is used to construct the +C error message so that no single character constant is +C continued to the next line. This avoids confusion as to +C whether there are trailing blanks at the end of the line. +C The second is that by catenating the parts of the message +C as an actual argument rather than encoding the entire +C message into one large character variable, we avoid +C having to know how long the message will be in order to +C declare an adequate length for that large character +C variable. XERMSG calls XERPRN to print the message using +C multiple lines if necessary. If the message is very long, +C XERPRN will break it into pieces of 72 characters (as +C requested by XERMSG) for printing on multiple lines. +C Also, XERMSG asks XERPRN to prefix each line with ' * ' +C so that the total line length could be 76 characters. +C Note also that XERPRN scans the error message backwards +C to ignore trailing blanks. Another feature is that +C the substring '$$' is treated as a new line sentinel +C by XERPRN. If you want to construct a multiline +C message without having to count out multiples of 72 +C characters, just use '$$' as a separator. '$$' +C obviously must occur within 72 characters of the +C start of each line to have its intended effect since +C XERPRN is asked to wrap around at 72 characters in +C addition to looking for '$$'. +C +C NERR An integer value that is chosen by the library routine's +C author. It must be in the range -99 to 999 (three +C printable digits). Each distinct error should have its +C own error number. These error numbers should be described +C in the machine readable documentation for the routine. +C The error numbers need be unique only within each routine, +C so it is reasonable for each routine to start enumerating +C errors from 1 and proceeding to the next integer. +C +C LEVEL An integer value in the range 0 to 2 that indicates the +C level (severity) of the error. Their meanings are +C +C -1 A warning message. This is used if it is not clear +C that there really is an error, but the user's attention +C may be needed. An attempt is made to only print this +C message once. +C +C 0 A warning message. This is used if it is not clear +C that there really is an error, but the user's attention +C may be needed. +C +C 1 A recoverable error. This is used even if the error is +C so serious that the routine cannot return any useful +C answer. If the user has told the error package to +C return after recoverable errors, then XERMSG will +C return to the Library routine which can then return to +C the user's routine. The user may also permit the error +C package to terminate the program upon encountering a +C recoverable error. +C +C 2 A fatal error. XERMSG will not return to its caller +C after it receives a fatal error. This level should +C hardly ever be used; it is much better to allow the +C user a chance to recover. An example of one of the few +C cases in which it is permissible to declare a level 2 +C error is a reverse communication Library routine that +C is likely to be called repeatedly until it integrates +C across some interval. If there is a serious error in +C the input such that another step cannot be taken and +C the Library routine is called again without the input +C error having been corrected by the caller, the Library +C routine will probably be called forever with improper +C input. In this case, it is reasonable to declare the +C error to be fatal. +C +C Each of the arguments to XERMSG is input; none will be modified by +C XERMSG. A routine may make multiple calls to XERMSG with warning +C level messages; however, after a call to XERMSG with a recoverable +C error, the routine should return to the user. Do not try to call +C XERMSG with a second recoverable error after the first recoverable +C error because the error package saves the error number. The user +C can retrieve this error number by calling another entry point in +C the error handling package and then clear the error number when +C recovering from the error. Calling XERMSG in succession causes the +C old error number to be overwritten by the latest error number. +C This is considered harmless for error numbers associated with +C warning messages but must not be done for error numbers of serious +C errors. After a call to XERMSG with a recoverable error, the user +C must be given a chance to call NUMXER or XERCLR to retrieve or +C clear the error number. +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE +C***REVISION HISTORY (YYMMDD) +C 880101 DATE WRITTEN +C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. +C THERE ARE TWO BASIC CHANGES. +C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO +C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES +C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS +C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE +C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER +C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY +C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE +C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. +C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE +C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE +C OF LOWER CASE. +C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. +C THE PRINCIPAL CHANGES ARE +C 1. CLARIFY COMMENTS IN THE PROLOGUES +C 2. RENAME XRPRNT TO XERPRN +C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES +C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / +C CHARACTER FOR NEW RECORDS. +C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO +C CLEAN UP THE CODING. +C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN +C PREFIX. +C 891013 REVISED TO CORRECT COMMENTS. +C 891214 Prologue converted to Version 4.0 format. (WRB) +C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but +C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added +C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and +C XERCTL to XERCNT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERMSG + CHARACTER*(*) LIBRAR, SUBROU, MESSG + CHARACTER*8 XLIBR, XSUBR + CHARACTER*72 TEMP + CHARACTER*20 LFIRST +C***FIRST EXECUTABLE STATEMENT XERMSG + LKNTRL = J4SAVE (2, 0, .FALSE.) + MAXMES = J4SAVE (4, 0, .FALSE.) +C +C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. +C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE +C SHOULD BE PRINTED. +C +C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN +C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, +C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. +C + IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. + * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN + CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // + * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// + * 'JOB ABORT DUE TO FATAL ERROR.', 72) + CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) + CALL XERHLT (' ***XERMSG -- INVALID INPUT') + RETURN + ENDIF +C +C RECORD THE MESSAGE. +C + I = J4SAVE (1, NERR, .TRUE.) + CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) +C +C HANDLE PRINT-ONCE WARNING MESSAGES. +C + IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN +C +C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. +C + XLIBR = LIBRAR + XSUBR = SUBROU + LFIRST = MESSG + LERR = NERR + LLEVEL = LEVEL + CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) +C + LKNTRL = MAX(-2, MIN(2,LKNTRL)) + MKNTRL = ABS(LKNTRL) +C +C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS +C ZERO AND THE ERROR IS NOT FATAL. +C + IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 + IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30 + IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30 + IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30 +C +C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A +C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) +C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG +C IS NOT ZERO. +C + IF (LKNTRL .NE. 0) THEN + TEMP(1:21) = 'MESSAGE FROM ROUTINE ' + I = MIN(LEN(SUBROU), 16) + TEMP(22:21+I) = SUBROU(1:I) + TEMP(22+I:33+I) = ' IN LIBRARY ' + LTEMP = 33 + I + I = MIN(LEN(LIBRAR), 16) + TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) + TEMP(LTEMP+I+1:LTEMP+I+1) = '.' + LTEMP = LTEMP + I + 1 + CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) + ENDIF +C +C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE +C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE +C FROM EACH OF THE FOLLOWING THREE OPTIONS. +C 1. LEVEL OF THE MESSAGE +C 'INFORMATIVE MESSAGE' +C 'POTENTIALLY RECOVERABLE ERROR' +C 'FATAL ERROR' +C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE +C 'PROG CONTINUES' +C 'PROG ABORTED' +C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK +C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS +C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) +C 'TRACEBACK REQUESTED' +C 'TRACEBACK NOT REQUESTED' +C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT +C EXCEED 74 CHARACTERS. +C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. +C + IF (LKNTRL .GT. 0) THEN +C +C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. +C + IF (LEVEL .LE. 0) THEN + TEMP(1:20) = 'INFORMATIVE MESSAGE,' + LTEMP = 20 + ELSEIF (LEVEL .EQ. 1) THEN + TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' + LTEMP = 30 + ELSE + TEMP(1:12) = 'FATAL ERROR,' + LTEMP = 12 + ENDIF +C +C THEN WHETHER THE PROGRAM WILL CONTINUE. +C + IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. + * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN + TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' + LTEMP = LTEMP + 14 + ELSE + TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' + LTEMP = LTEMP + 16 + ENDIF +C +C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. +C + IF (LKNTRL .GT. 0) THEN + TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' + LTEMP = LTEMP + 20 + ELSE + TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' + LTEMP = LTEMP + 24 + ENDIF + CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) + ENDIF +C +C NOW SEND OUT THE MESSAGE. +C + CALL XERPRN (' * ', -1, MESSG, 72) +C +C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A +C TRACEBACK. +C + IF (LKNTRL .GT. 0) THEN + WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR + DO 10 I=16,22 + IF (TEMP(I:I) .NE. ' ') GO TO 20 + 10 CONTINUE +C + 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) + CALL FDUMP + ENDIF +C +C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. +C + IF (LKNTRL .NE. 0) THEN + CALL XERPRN (' * ', -1, ' ', 72) + CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) + CALL XERPRN (' ', 0, ' ', 72) + ENDIF +C +C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE +C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. +C + 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN +C +C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A +C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR +C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. +C + IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN + IF (LEVEL .EQ. 1) THEN + CALL XERPRN + * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) + ELSE + CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) + ENDIF + CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) + CALL XERHLT (' ') + ELSE + CALL XERHLT (MESSG) + ENDIF + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xerprn.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xerprn.f new file mode 100644 index 0000000..97eedf4 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xerprn.f @@ -0,0 +1,228 @@ +*DECK XERPRN + SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) +C***BEGIN PROLOGUE XERPRN +C***SUBSIDIARY +C***PURPOSE Print error messages processed by XERMSG. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERPRN-A) +C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR +C***AUTHOR Fong, Kirby, (NMFECC at LLNL) +C***DESCRIPTION +C +C This routine sends one or more lines to each of the (up to five) +C logical units to which error messages are to be sent. This routine +C is called several times by XERMSG, sometimes with a single line to +C print and sometimes with a (potentially very long) message that may +C wrap around into multiple lines. +C +C PREFIX Input argument of type CHARACTER. This argument contains +C characters to be put at the beginning of each line before +C the body of the message. No more than 16 characters of +C PREFIX will be used. +C +C NPREF Input argument of type INTEGER. This argument is the number +C of characters to use from PREFIX. If it is negative, the +C intrinsic function LEN is used to determine its length. If +C it is zero, PREFIX is not used. If it exceeds 16 or if +C LEN(PREFIX) exceeds 16, only the first 16 characters will be +C used. If NPREF is positive and the length of PREFIX is less +C than NPREF, a copy of PREFIX extended with blanks to length +C NPREF will be used. +C +C MESSG Input argument of type CHARACTER. This is the text of a +C message to be printed. If it is a long message, it will be +C broken into pieces for printing on multiple lines. Each line +C will start with the appropriate prefix and be followed by a +C piece of the message. NWRAP is the number of characters per +C piece; that is, after each NWRAP characters, we break and +C start a new line. In addition the characters '$$' embedded +C in MESSG are a sentinel for a new line. The counting of +C characters up to NWRAP starts over for each new line. The +C value of NWRAP typically used by XERMSG is 72 since many +C older error messages in the SLATEC Library are laid out to +C rely on wrap-around every 72 characters. +C +C NWRAP Input argument of type INTEGER. This gives the maximum size +C piece into which to break MESSG for printing on multiple +C lines. An embedded '$$' ends a line, and the count restarts +C at the following character. If a line break does not occur +C on a blank (it would split a word) that word is moved to the +C next line. Values of NWRAP less than 16 will be treated as +C 16. Values of NWRAP greater than 132 will be treated as 132. +C The actual line length will be NPREF + NWRAP after NPREF has +C been adjusted to fall between 0 and 16 and NWRAP has been +C adjusted to fall between 16 and 132. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED I1MACH, XGETUA +C***REVISION HISTORY (YYMMDD) +C 880621 DATE WRITTEN +C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF +C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK +C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE +C SLASH CHARACTER IN FORMAT STATEMENTS. +C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO +C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK +C LINES TO BE PRINTED. +C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF +C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. +C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. +C 891214 Prologue converted to Version 4.0 format. (WRB) +C 900510 Added code to break messages between words. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERPRN + CHARACTER*(*) PREFIX, MESSG + INTEGER NPREF, NWRAP + CHARACTER*148 CBUFF + INTEGER IU(5), NUNIT + CHARACTER*2 NEWLIN + PARAMETER (NEWLIN = '$$') +C***FIRST EXECUTABLE STATEMENT XERPRN + CALL XGETUA(IU,NUNIT) +C +C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD +C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD +C ERROR MESSAGE UNIT. +C + N = I1MACH(4) + DO 10 I=1,NUNIT + IF (IU(I) .EQ. 0) IU(I) = N + 10 CONTINUE +C +C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE +C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING +C THE REST OF THIS ROUTINE. +C + IF ( NPREF .LT. 0 ) THEN + LPREF = LEN(PREFIX) + ELSE + LPREF = NPREF + ENDIF + LPREF = MIN(16, LPREF) + IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX +C +C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE +C TIME FROM MESSG TO PRINT ON ONE LINE. +C + LWRAP = MAX(16, MIN(132, NWRAP)) +C +C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. +C + LENMSG = LEN(MESSG) + N = LENMSG + DO 20 I=1,N + IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 + LENMSG = LENMSG - 1 + 20 CONTINUE + 30 CONTINUE +C +C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. +C + IF (LENMSG .EQ. 0) THEN + CBUFF(LPREF+1:LPREF+1) = ' ' + DO 40 I=1,NUNIT + WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) + 40 CONTINUE + RETURN + ENDIF +C +C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING +C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. +C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. +C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. +C +C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE +C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE +C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH +C OF THE SECOND ARGUMENT. +C +C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE +C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER +C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT +C POSITION NEXTC. +C +C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE +C REMAINDER OF THE CHARACTER STRING. LPIECE +C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, +C WHICHEVER IS LESS. +C +C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: +C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE +C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY +C BLANK LINES. THIS TAKES CARE OF THE SITUATION +C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF +C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE +C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC +C SHOULD BE INCREMENTED BY 2. +C +C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. +C +C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 +C RESET LPIECE = LPIECE-1. NOTE THAT THIS +C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. +C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY +C AT THE END OF A LINE. +C + NEXTC = 1 + 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) + IF (LPIECE .EQ. 0) THEN +C +C THERE WAS NO NEW LINE SENTINEL FOUND. +C + IDELTA = 0 + LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) + IF (LPIECE .LT. LENMSG+1-NEXTC) THEN + DO 52 I=LPIECE+1,2,-1 + IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN + LPIECE = I-1 + IDELTA = 1 + GOTO 54 + ENDIF + 52 CONTINUE + ENDIF + 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + IDELTA + ELSEIF (LPIECE .EQ. 1) THEN +C +C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). +C DON'T PRINT A BLANK LINE. +C + NEXTC = NEXTC + 2 + GO TO 50 + ELSEIF (LPIECE .GT. LWRAP+1) THEN +C +C LPIECE SHOULD BE SET DOWN TO LWRAP. +C + IDELTA = 0 + LPIECE = LWRAP + DO 56 I=LPIECE+1,2,-1 + IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN + LPIECE = I-1 + IDELTA = 1 + GOTO 58 + ENDIF + 56 CONTINUE + 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + IDELTA + ELSE +C +C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. +C WE SHOULD DECREMENT LPIECE BY ONE. +C + LPIECE = LPIECE - 1 + CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + 2 + ENDIF +C +C PRINT +C + DO 60 I=1,NUNIT + WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) + 60 CONTINUE +C + IF (NEXTC .LE. LENMSG) GO TO 50 + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xersve.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xersve.f new file mode 100644 index 0000000..6bd2a4f --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xersve.f @@ -0,0 +1,155 @@ +*DECK XERSVE + SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, + + ICOUNT) +C***BEGIN PROLOGUE XERSVE +C***SUBSIDIARY +C***PURPOSE Record that an error has occurred. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3 +C***TYPE ALL (XERSVE-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C *Usage: +C +C INTEGER KFLAG, NERR, LEVEL, ICOUNT +C CHARACTER * (len) LIBRAR, SUBROU, MESSG +C +C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) +C +C *Arguments: +C +C LIBRAR :IN is the library that the message is from. +C SUBROU :IN is the subroutine that the message is from. +C MESSG :IN is the message to be saved. +C KFLAG :IN indicates the action to be performed. +C when KFLAG > 0, the message in MESSG is saved. +C when KFLAG=0 the tables will be dumped and +C cleared. +C when KFLAG < 0, the tables will be dumped and +C not cleared. +C NERR :IN is the error number. +C LEVEL :IN is the error severity. +C ICOUNT :OUT the number of times this message has been seen, +C or zero if the table has overflowed and does not +C contain this message specifically. When KFLAG=0, +C ICOUNT will not be altered. +C +C *Description: +C +C Record that this error occurred and possibly dump and clear the +C tables. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED I1MACH, XGETUA +C***REVISION HISTORY (YYMMDD) +C 800319 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900413 Routine modified to remove reference to KFLAG. (WRB) +C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling +C sequence, use IF-THEN-ELSE, make number of saved entries +C easily changeable, changed routine name from XERSAV to +C XERSVE. (RWC) +C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERSVE + PARAMETER (LENTAB=10) + INTEGER LUN(5) + CHARACTER*(*) LIBRAR, SUBROU, MESSG + CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB + CHARACTER*20 MESTAB(LENTAB), MES + DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB) + SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG + DATA KOUNTX/0/, NMSG/0/ +C***FIRST EXECUTABLE STATEMENT XERSVE +C + IF (KFLAG.LE.0) THEN +C +C Dump the table. +C + IF (NMSG.EQ.0) RETURN +C +C Print to each unit. +C + CALL XGETUA (LUN, NUNIT) + DO 20 KUNIT = 1,NUNIT + IUNIT = LUN(KUNIT) + IF (IUNIT.EQ.0) IUNIT = I1MACH(4) +C +C Print the table header. +C + WRITE (IUNIT,9000) +C +C Print body of table. +C + DO 10 I = 1,NMSG + WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), + * NERTAB(I),LEVTAB(I),KOUNT(I) + 10 CONTINUE +C +C Print number of other errors. +C + IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX + WRITE (IUNIT,9030) + 20 CONTINUE +C +C Clear the error tables. +C + IF (KFLAG.EQ.0) THEN + NMSG = 0 + KOUNTX = 0 + ENDIF + ELSE +C +C PROCESS A MESSAGE... +C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, +C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. +C + LIB = LIBRAR + SUB = SUBROU + MES = MESSG + DO 30 I = 1,NMSG + IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND. + * MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND. + * LEVEL.EQ.LEVTAB(I)) THEN + KOUNT(I) = KOUNT(I) + 1 + ICOUNT = KOUNT(I) + RETURN + ENDIF + 30 CONTINUE +C + IF (NMSG.LT.LENTAB) THEN +C +C Empty slot found for new message. +C + NMSG = NMSG + 1 + LIBTAB(I) = LIB + SUBTAB(I) = SUB + MESTAB(I) = MES + NERTAB(I) = NERR + LEVTAB(I) = LEVEL + KOUNT (I) = 1 + ICOUNT = 1 + ELSE +C +C Table is full. +C + KOUNTX = KOUNTX+1 + ICOUNT = 0 + ENDIF + ENDIF + RETURN +C +C Formats. +C + 9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / + + ' LIBRARY SUBROUTINE MESSAGE START NERR', + + ' LEVEL COUNT') + 9010 FORMAT (1X,A,3X,A,3X,A,3I10) + 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10) + 9030 FORMAT (1X) + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xgetua.f b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xgetua.f new file mode 100644 index 0000000..2e7db02 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xgetua.f @@ -0,0 +1,51 @@ +*DECK XGETUA + SUBROUTINE XGETUA (IUNITA, N) +C***BEGIN PROLOGUE XGETUA +C***PURPOSE Return unit number(s) to which error messages are being +C sent. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XGETUA-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C XGETUA may be called to determine the unit number or numbers +C to which error messages are being sent. +C These unit numbers may have been set by a call to XSETUN, +C or a call to XSETUA, or may be a default value. +C +C Description of Parameters +C --Output-- +C IUNIT - an array of one to five unit numbers, depending +C on the value of N. A value of zero refers to the +C default unit, as defined by the I1MACH machine +C constant routine. Only IUNIT(1),...,IUNIT(N) are +C defined by XGETUA. The values of IUNIT(N+1),..., +C IUNIT(5) are not defined (for N .LT. 5) or altered +C in any way by XGETUA. +C N - the number of units to which copies of the +C error messages are being sent. N will be in the +C range from 1 to 5. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED J4SAVE +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XGETUA + DIMENSION IUNITA(5) +C***FIRST EXECUTABLE STATEMENT XGETUA + N = J4SAVE(5,0,.FALSE.) + DO 30 I=1,N + INDEX = I+4 + IF (I.EQ.1) INDEX = 3 + IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) + 30 CONTINUE + RETURN + END diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/spectrum.f b/binaries/src/disembl/Tisean_3.0.1/source_f/spectrum.f new file mode 100644 index 0000000..955137c --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/spectrum.f @@ -0,0 +1,79 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c Fourier power spectrum +c author T. Schreiber (1998) and earlier +c modified by H. Kantz 2007 +c=========================================================================== + parameter(nx=1000000) + dimension x(nx) + character*72 file, fout + data h/1./, dh/0./ + data iverb/1/ + + call whatido("Power spectrum by FFT",iverb) + nmaxx=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + h=fcan("f",h) + dh=fcan("w",dh) + isout=igetout(fout,iverb) + + do 10 ifi=1,nstrings() + call nthstring(ifi,file) + nmax=nmaxx + call readfile(nmax,x,nexcl,jcol,file,iverb) + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_sp") + nmaxp=nless(nmax) + if(nmaxp.ne.nmax) + . write(istderr(),*) "spectrum: using first ", nmaxp + if(dh.eq.0.) dh=h/nmaxp + ibin=nmaxp*dh/(2*h) + if(ibin.gt.0) write(istderr(),*) + . "spectrum: binning", 2*ibin+1," frequencies" + call store_spec(nmaxp,x,0) + call outfile(fout,iunit,iverb) + write(iunit,*) 0., x(1) + do 20 i=2+ibin,nmaxp/2+1-ibin,2*ibin+1 + p=0 + do 30 ib=i-ibin,i+ibin + 30 p=p+x(2*ib-2) + 20 write(iunit,*) h*(i-1)/real(nmaxp), p + if(iunit.eq.istdout()) write(iunit,*) + if(iunit.eq.istdout()) write(iunit,*) + 10 if(iunit.ne.istdout()) close(iunit) + end + + subroutine usage() +c usage message + + call whatineed( + . "[-f# -w# -o outfile -l# -x# -c# -V# -h] file(s)") + call popt("f","sampling rate, e.g. in Hz [default 1.]") + call popt("w","frequency resolution, e.g. in Hz, [default 1/N]") + call popt("l","number of values to be read [all]") + call popt("x","number of values to be skipped [0]") + call popt("c","column to be read, [1] or file,#") + call pout("file_sp") + call pall() + stop + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/spikeauto.f b/binaries/src/disembl/Tisean_3.0.1/source_f/spikeauto.f new file mode 100644 index 0000000..92ede7b --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/spikeauto.f @@ -0,0 +1,81 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c spike train autocorrelation function +c author T. Schreiber (1998) based on earlier versions +c=========================================================================== + parameter(nx=1000000, nhist=100000) + dimension x(nx), lx(nx), ihist(nhist) + character*72 file, fout + data iverb/1/ + + call whatido("spike train autocorrelation function",iverb) + bin=fmust("d") + totbin=fmust("D") + nbin=int(totbin/bin)+1 + nmaxx=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + inter=lopt("i",1) + isout=igetout(fout,iverb) + + do 10 ifi=1,nstrings() + call nthstring(ifi,file) + nmax=nmaxx + call readfile(nmax,x,nexcl,jcol,file,iverb) + if(inter.eq.0) goto 1 + do 20 n=2,nmax + 20 x(n)=x(n)+x(n-1) + 1 call sort(nmax,x,lx) + do 30 i=1,nbin + 30 ihist(i)=0 + do 40 n1=1,nmax + do 50 n2=n1+1,nmax + il=int((x(n2)-x(n1))/bin)+1 + if(il.gt.nbin) goto 40 + 50 ihist(il)=ihist(il)+1 + 40 continue + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_sco") + call outfile(fout,iunit,iverb) + do 60 i=1,nbin + 60 write(iunit,*) (i-0.5)*bin, ihist(i) + 10 if(iunit.ne.istdout()) close(iunit) + end + + subroutine usage() +c usage message + + call whatineed( + . "-d# -D# [-i -o outfile -l# -x# -c# -V# -h] file(s)") + call popt("d","time span of one bin") + call popt("D","total time spanned") + call popt("i","expect intervals rather than times") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_sco") + call pall() + stop + end + + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/spikespec.f b/binaries/src/disembl/Tisean_3.0.1/source_f/spikespec.f new file mode 100644 index 0000000..293890c --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/spikespec.f @@ -0,0 +1,105 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c power spectrum of spike trains +c author T. Schreiber (1999) +c=========================================================================== + parameter(nx=1000000) + dimension x(nx), lx(nx), sp(nx) + character*72 file, fout + data iverb/1/ + + call whatido("power spectrum of spike trains",iverb) + nmaxx=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + fmax=fcan("F",0) + nfreq=min(ican("#",0),nx) + fres=fcan("w",0) + inter=lopt("i",1) + isout=igetout(fout,iverb) + + do 10 ifi=1,nstrings() + call nthstring(ifi,file) + nmax=nmaxx + call readfile(nmax,x,nexcl,jcol,file,iverb) + if(inter.eq.0) goto 1 + do 20 n=2,nmax + 20 x(n)=x(n)+x(n-1) + 1 call sort(nmax,x,lx) + if(fmax.le.0.) fmax=2*nmax/(x(nmax)-x(1)) + if(nfreq.le.0) nfreq=fmax*(x(nmax)-x(1))/2 + write(istderr(),*) "spikespec: total time covered: ", + . x(nmax)-x(1) + write(istderr(),*) "spikespec: computing ", nfreq, + . " frequencies up to ", fmax + do 30 n=1,nfreq + f=(n*fmax)/nfreq + 30 sp(n)=sspect(nmax,x,f) + ibin=nfreq*fres/2 + if(ibin.gt.0) write(istderr(),*) + . "spikespec: binning", 2*ibin+1," frequencies" + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_ss") + call outfile(fout,iunit,iverb) + do 40 n=1+ibin,nfreq-ibin,2*ibin+1 + f=(n*fmax)/nfreq + p=0 + do 50 ib=n-ibin,n+ibin + 50 p=p+sp(ib) + 40 write(iunit,*) f, p + if(iunit.eq.istdout()) write(iunit,*) + if(iunit.eq.istdout()) write(iunit,*) + 10 if(iunit.ne.istdout()) close(iunit) + end + + function sspect(nmax,x,f) + dimension x(nmax) + data pi/3.1415926/ + + omega=2*pi*f + sr=0 + si=0 + do 10 n=1,nmax + sr=sr+cos(omega*x(n)) + 10 si=si+sin(omega*x(n)) + sspect=sr**2+si**2 + end + + subroutine usage() +c usage message + + call whatineed( + . "[-F# -## -w# -i -o outfile -l# -x# -c# -V# -h] file(s)") + call popt("F","maximal frequency [2*l / total time]") + call popt("#","number of frequencies [F* total time /2]") + call popt("w","frequency resolution [0]") + call popt("i","input data: intervals rather than times") + call popt("l","number of values to be read [all]") + call popt("x","number of values to be skipped [0]") + call popt("c","column to be read [1 or file,#]") + call pout("file_ss") + call pall() + stop + end + + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/store_spec.f b/binaries/src/disembl/Tisean_3.0.1/source_f/store_spec.f new file mode 100644 index 0000000..670717c --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/store_spec.f @@ -0,0 +1,49 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c store data periodogram of x +c if iback.ne.0 transform back to get autocorrelation instead +C author Thomas Schreiber (1998) +c=========================================================================== + subroutine store_spec(nmax,x,iback) + parameter(nx=1000000) + dimension x(nmax), w1(nx), w2(nx), iw(15) + save w2, iw + + if(nmax.gt.nx) stop "store_spec: make nx larger." + call rffti1(nmax,w2,iw) + call rfftf1(nmax,x,w1,w2,iw) + do 10 n=1,nmax + 10 x(n)=x(n)/real(nmax) + x(1)=x(1)**2 + do 20 n=2,(nmax+1)/2 + amp=x(2*n-2)**2+x(2*n-1)**2 + pha=atan2(x(2*n-1),x(2*n-2)) + x(2*n-2)=amp + 20 x(2*n-1)=pha + if(mod(nmax,2).eq.0) x(nmax)=x(nmax)**2 + if(iback.eq.0) return + do 30 n=1,nmax + 30 x(n)=x(n)*nmax + do 40 n=2,(nmax+1)/2 + 40 x(2*n-1)=0 + call rfftb1(nmax,x,w1,w2,iw) + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/stp.f b/binaries/src/disembl/Tisean_3.0.1/source_f/stp.f new file mode 100644 index 0000000..eff332f --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/stp.f @@ -0,0 +1,104 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c space time separation plot +c see H. Kantz, T. Schreiber, Nonlinear Time Series Analysis, Cambridge +c University Press (1997,2004) +c author T. Schreiber (1998) based on earlier version +c========================================================================== + parameter(nx=1000000,mdt=500,mfrac=100) + dimension x(nx), stp(mfrac,mdt) + character*72 file, fout + data idt/1/, perc/0.05/, ndt/100/ + data iverb/1/ + + call whatido("space-time separation plot",iverb) + id=imust("d") + m=imust("m") + idt=ican("#",idt) + ndt=min(ican("t",ndt),mdt) + perc=fcan("%",perc) + nfrac=min(mfrac,int(1/perc)) + perc=1./real(nfrac) + nmax=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + isout=igetout(fout,iverb) + if(iv_io(iverb).eq.1) write(istderr(),*) "computing ", nfrac, + . " levels at fractions ", perc, 2*perc, "..." + + call nthstring(1,file) + call readfile(nmax,x,nexcl,jcol,file,iverb) + call minmax(nmax,x,xmin,xmax) + call stplot(nmax,x,id,m,xmax-xmin,stp,nfrac,ndt,idt) + if(isout.eq.1) call addsuff(fout,file,"_stp") + call outfile(fout,iunit,iverb) + do 10 iper=1,mfrac + do 20 it=1,ndt + 20 write(iunit,*) it*idt, stp(iper,it) + 10 write(iunit,'()') + end + + subroutine usage() +c usage message + + call whatineed( + . " -d# -m# [-## -t# -%# -o outfile -l# -x# -c# -V# -h] file") + call popt("d","delay") + call popt("m","embedding dimension") + call popt("#","time resolution (1)") + call popt("t","time steps (100, <500)") + call popt("%","fraction at wich to create levels (0.05, >0.01)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_stp") + call pall() + stop + end + + subroutine stplot(nmax,y,id,m,epsmax,stp,nfrac,mdt,idt) + parameter(meps=1000,mfrac=100) + dimension y(nmax),stp(mfrac,mdt),ihist(meps) + + do 10 it=1,mdt + do 20 ieps=1,meps + 20 ihist(ieps)=0 + do 30 n=it*idt+(m-1)*id+1,nmax + dis=0 ! compute distance in m dimensions + do 40 me=0,m-1 + 40 dis=max(dis,abs(y(n-me*id)-y(n-me*id-it*idt))) + ih=min(int(meps*dis/epsmax)+1,meps) + 30 ihist(ih)=ihist(ih)+1 + do 10 ifrac=1,nfrac + need=(nmax-it*idt-(m-1)*id)*ifrac/real(nfrac) + is=0 + do 50 ieps=1,meps + is=is+ihist(ieps) + 50 if(is.ge.need) goto 1 + 1 stp(ifrac,it)=ieps*epsmax/meps + 10 continue + end + + + + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/surrogates.f b/binaries/src/disembl/Tisean_3.0.1/source_f/surrogates.f new file mode 100644 index 0000000..1b49b47 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/surrogates.f @@ -0,0 +1,179 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c Create multivariate surrogate data +c author T. Schreiber (1999) +c=========================================================================== + parameter(nx=100000,mx=20) + dimension xx(nx,mx), x(nx,mx), y(nx,mx), xamp(nx,mx), + . xsort(nx,mx), list(nx), icol(mx), rwork(nx) + character*72 file, fout + data nsur/1/, imax/-1/ + external rand + data iverb/15/ + + call whatido("Create Multivariate Surrogate data",iverb) + nmax=ican("l",nx) + nexcl=ican("x",0) + nsur=min(999,ican("n",nsur)) + imax=ican("i",imax) + ispec=lopt("S",1) + r=rand(sqrt(abs(fcan("I",0.0)))) + mcmax=ican("m",0) + call columns(mc,mx,icol) + if(mcmax.eq.0) mcmax=max(1,mc) + isout=igetout(fout,iverb) + + call nthstring(1,file) + call xreadfile(nmax,mcmax,nx,xx,nexcl,icol,file,iverb) + nmaxp=nless(nmax) + if(nmaxp.ne.nmax.and.iv_io(iverb).eq.1) + . write(istderr(),*) "surrogates: using first ", nmaxp + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_surr") + if(nsur.gt.1.and.isout.eq.1) call suffix(fout,"_000") + + do 10 isur=1,nsur + if(nsur.gt.1.and.isout.eq.1) + . write(fout(index(fout," ")-3:72),'(i3.3)') isur + do 20 m=1,mcmax + do 30 n=1,nmaxp + x(n,m)=xx(n,m) + y(n,m)=x(n,m) + xamp(n,m)=x(n,m) + 30 xsort(n,m)=x(n,m) + call store_spec(nmaxp,xamp(1,m),0) + call sort(nmaxp,xsort(1,m),list) + do 40 n=1,nmaxp + 40 rwork(n)=rand(0.0) + call rank(nmaxp,rwork,list) + 20 call index2sort(nmaxp,x(1,m),list) + it=-1 + dspec=r1mach(2) + 1 it=it+1 + do 50 m=1,mcmax + do 50 n=1,nmaxp + 50 y(n,m)=x(n,m) + ds0=dspec + dspec=toxspec(nmaxp,mcmax,nx,xamp,y) + if(imax.ge.0.and.it.ge.imax) goto 2 + do 60 m=1,mcmax + 60 call todist(nmaxp,xsort(1,m),y(1,m),x(1,m)) + if(dspec.lt.ds0) goto 1 + 2 continue + if(ispec.gt.0) then + call xwritefile(nmaxp,mcmax,nx,y,fout,iverb) + else + call xwritefile(nmaxp,mcmax,nx,x,fout,iverb) + endif + 10 if(iv_surr(iverb).eq.1) write(istderr(),*) + . fout(1:index(fout," ")), ' (', it, + . ' iterations, relative discrepancy ', dspec, ')' + end + + subroutine usage() +c usage message + + call whatineed( + . "[-n# -i# -S -I# -o outfile -l# -x# -m# -c#[,#] -V# -h] file") + call popt("n","number of surrogates (1)") + call popt("i","number of iterations (until no change)") + call popt("S","make spectrum exact rather than distribution") + call popt("I","seed for random numbers") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("m","number of columns to be read (1)") + call popt("c","columns to be read (1)") + call pout("file_surr(_nnn)") + call pall() + call ptext("Verbosity levels (add what you want):") + call ptext(" 1 = input/output" ) + call ptext(" 2 = iterations / discrepancy") + stop + end + + function toxspec(nmax,mmax,nxx,a,x) + parameter(nx=100000,mx=20,tol=1e-5) + dimension x(nxx,mmax), a(nxx,mmax), w(nx,mx), w1(nx), + . w2(nx), iw(15), goal(mx) + + if(nmax.gt.nx.or.mmax.gt.mx) stop "toxspec: make nx/mx larger." + call rffti1(nmax,w2,iw) + do 10 m=1,mmax + do 20 n=1,nmax + 20 w(n,m)=x(n,m) + call rfftf1(nmax,x(1,m),w1,w2,iw) + do 30 n=1,nmax + 30 x(n,m)=x(n,m)/real(nmax) + x(1,m)=sqrt(a(1,m)) + do 40 n=2,(nmax+1)/2 + pha=atan2(x(2*n-1,m),x(2*n-2,m)) + x(2*n-2,m)=sqrt(a(2*n-2,m)) + 40 x(2*n-1,m)=pha + 10 if(mod(nmax,2).eq.0) x(nmax,m)=sqrt(a(nmax,m)) + if(mmax.gt.1) then + do 50 n=2,(nmax+1)/2 + do 60 m=1,mmax + 60 goal(m)=x(2*n-1,m)-a(2*n-1,m) + alpha=alp(mmax,goal) + do 50 m=1,mmax + 50 x(2*n-1,m)=alpha+a(2*n-1,m) + endif + do 70 m=1,mmax + do 80 n=2,(nmax+1)/2 + c=x(2*n-2,m)*cos(x(2*n-1,m)) + s=x(2*n-2,m)*sin(x(2*n-1,m)) + x(2*n-1,m)=s + 80 x(2*n-2,m)=c + 70 call rfftb1(nmax,x(1,m),w1,w2,iw) + toxspec=0 + do 90 m=1,mmax + do 90 n=1,nmax + 90 toxspec=toxspec+(x(n,m)-w(n,m))**2 + toxspec=sqrt((toxspec/nmax)/mmax) + end + + function alp(mmax,goal) + dimension goal(mmax) + data pi/3.1415926/ + + f1=0 + f2=0 + do 10 m=1,mmax + f1=f1+cos(goal(m)) + 10 f2=f2+sin(goal(m)) + alp=atan2(f2,f1) + scos=0 + do 20 m=1,mmax + 20 scos=scos+cos(alp-goal(m)) + if(scos.lt.0) alp=alp+pi + end + + subroutine todist(nmax,dist,x,y) + parameter(nx=100000) + dimension x(nmax), dist(nmax), y(nmax), list(nx) + + if(nmax.gt.nx) stop "todist: make nx larger." + call rank(nmax,x,list) + do 10 n=1,nmax + 10 y(n)=dist(list(n)) + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/timerev.f b/binaries/src/disembl/Tisean_3.0.1/source_f/timerev.f new file mode 100644 index 0000000..a931cb9 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/timerev.f @@ -0,0 +1,61 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c Statistics for time reversibility +c author T. Schreiber (1999) +c=========================================================================== + parameter(nx=1000000) + dimension x(nx) + character*72 file + data iverb/1/ + + call whatido("time reversal asymmetry statistic",iverb) + id=abs(ican("d",1)) + nmaxx=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) +c isout=igetout(fout,iverb) + + do 10 ifi=1,nstrings() + call nthstring(ifi,file) + nmax=nmaxx + call readfile(nmax,x,nexcl,jcol,file,iverb) + t2=0 + t3=0 + do 20 n=id+1,nmax + t2=t2+(x(n)-x(n-id))**2 + 20 t3=t3+(x(n)-x(n-id))**3 + 10 write(*,*) t3/t2, " "//file(1:index(file," ")-1) + end + + subroutine usage() +c usage message + + call whatineed( + . "[-d# -l# -x# -c# -V# -h] file(s)") + call popt("d","delay (1)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pall() + stop + end + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/tospec.f b/binaries/src/disembl/Tisean_3.0.1/source_f/tospec.f new file mode 100644 index 0000000..5821cf9 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/tospec.f @@ -0,0 +1,53 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c Wiener filter x according to spectrum a +c (routine needed by surrogates.f) +C author Thomas Schreiber (1998) +c=========================================================================== + function tospec(nmax,a,x,ibin) + parameter(nx=1000000) + dimension x(nmax), a(nmax), w(nx), w1(nx), w2(nx), iw(15) + save w2, iw + + if(nmax.gt.nx) stop "tospec: make nx larger." + do 10 n=1,nmax + 10 w(n)=x(n) + call rffti1(nmax,w2,iw) + call rfftf1(nmax,x,w1,w2,iw) + do 20 n=1,nmax + 20 x(n)=x(n)/real(nmax) + x(1)=x(1)*(a(1)/x(1)**2) + do 30 i=2+ibin,(nmax+1)/2-ibin,2*ibin+1 + p=0 + do 40 ib=i-ibin,i+ibin + 40 p=p+x(2*ib-2)**2+x(2*ib-1)**2 + ab=a(2*i-2)/p + do 30 ib=i-ibin,i+ibin + x(2*ib-2)=x(2*ib-2)*ab + 30 x(2*ib-1)=x(2*ib-1)*ab + if(mod(nmax,2).eq.0) x(nmax)=x(nmax)*(a(nmax)/x(nmax)**2) + call rfftb1(nmax,x,w1,w2,iw) + tospec=0 + do 50 n=1,nmax + 50 tospec=tospec+(x(n)-w(n))**2 + tospec=sqrt(tospec/nmax) + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/totospec.f b/binaries/src/disembl/Tisean_3.0.1/source_f/totospec.f new file mode 100644 index 0000000..001a049 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/totospec.f @@ -0,0 +1,48 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c Force x to have spectrum a (routine needed by surrogates.f) +C author Thomas Schreiber (1999) +c=========================================================================== + function totospec(nmax,a,x) + parameter(nx=1000000) + dimension x(nmax), a(nmax), w(nx), w1(nx), w2(nx), iw(15) + save w2, iw + + if(nmax.gt.nx) stop "totospec: make nx larger." + do 10 n=1,nmax + 10 w(n)=x(n) + call rffti1(nmax,w2,iw) + call rfftf1(nmax,x,w1,w2,iw) + do 20 n=1,nmax + 20 x(n)=x(n)/real(nmax) + x(1)=sqrt(a(1)) + do 30 n=2,(nmax+1)/2 + ab=a(2*n-2)/(x(2*n-2)**2+x(2*n-1)**2) + x(2*n-2)=x(2*n-2)*sqrt(ab) + 30 x(2*n-1)=x(2*n-1)*sqrt(ab) + if(mod(nmax,2).eq.0) x(nmax)=sqrt(a(nmax)) + call rfftb1(nmax,x,w1,w2,iw) + totospec=0 + do 40 n=1,nmax + 40 totospec=totospec+(x(n)-w(n))**2 + totospec=sqrt(totospec/nmax) + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/upo.f b/binaries/src/disembl/Tisean_3.0.1/source_f/upo.f new file mode 100644 index 0000000..224f9d0 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/upo.f @@ -0,0 +1,268 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c locate unstable periodic points +c author T. Schreiber (1998) +c=========================================================================== + parameter(nx=1000000,mper=20) + dimension x(nx) + character*72 file, fout + common /period/ x, nmax, m, eps + data frac/0./, iper/1/, teq/-1./, tdis/-1./, tacc/-1./, h/-1./ + data iverb/1/ + + call whatido("locate unstable periodic points",iverb) + m=max(imust("m"),1) + eps=fcan("r",0.) + frac=fcan("v",frac) + teq=fcan("w",teq) + tdis=fcan("W",tdis) + h=fcan("s",h) + tacc=fcan("a",tacc) + iper=ican("p",iper) + nmaxx=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + icen=ican("n",nmaxx) + isout=igetout(fout,iverb) + if(eps.eq.0.and.frac.eq.0.) call usage() + + do 10 ifi=1,nstrings() + call nthstring(ifi,file) + nmax=nmaxx + call readfile(nmax,x,nexcl,jcol,file,iverb) + if(file.eq."-") file="stdin" + if(isout.eq.1) call addsuff(fout,file,"_upo_") + call rms(nmax,x,sc,sd) + if(frac.gt.0) eps=sd*frac + if(teq.lt.0.) teq=eps + if(tdis.lt.0.) tdis=eps + if(tacc.lt.0.) tacc=eps + if(h.lt.0.) h=eps + if(isout.eq.1) + . write(fout(index(fout,"_upo_")+5:72),'(i2.2)') iper + call outfile(fout,iunit,iverb) + call findupo(iper,icen,teq,tdis,tacc,h,iunit,iverb) + 10 if(iunit.ne.istdout()) close(iunit) + end + + subroutine usage() +c usage message + call whatineed( + . "-m# [-r# | -v#] [-p# -w# -W# -a# -s# -n#"// + . " -o outfile -l# -x# -c# -V# -h] file(s)") + call ptext("either -r or -v must be present") + call popt("m","embedding dimension") + call popt("r","absolute kernel bandwidth") + call popt("v","same as fraction of standard deviation") + call popt("p","period of orbit (1)") + call popt("w","minimal separation of trial points (e)") + call popt("W","minimal separation of distinct orbits (e)") + call popt("a", + . "maximal error of orbit to be plotted (all plotted)") + call popt("s","initial separation for stability (e)") + call popt("n","number of trials (all points)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_upo_pp") + call pall() + call ptext("Verbosity levels (add what you want):") + call ptext(" 1 = input/output" ) + call ptext(" 2 = print orbits found") + call ptext(" 4 = status after 1000 points") + call ptext(" 8 = status after 100 points") + call ptext(" 16 = status after 10 points") + stop + end + + subroutine findupo(iper,icen,teq,tdis,tacc,h,iunit,iverb) + parameter(nx=1000000,mper=20) + external peri + dimension x(nx),xp(mper),fvec(mper),xor(mper,nx), + . iw(mper),w0(mper,mper),w1(mper),w2(mper),w3(mper), + . w4(mper),w5(mper),w6(mper) + common /period/ x, nmax, m, eps + + if(iper.gt.mper) stop "findupo: make mper larger." + tol=sqrt(r1mach(4)) + itry=0 + ior=0 + do 10 n=iper,nmax + if(iv_10(iverb).eq.1) then + if(mod(n,10).eq.0) write(istderr(),'(i7)') n + else if(iv_100(iverb).eq.1) then + if(mod(n,100).eq.0) write(istderr(),'(i7)') n + else if(iv_1000(iverb).eq.1) then + if(mod(n,1000).eq.0) write(istderr(),'(i7)') n + endif + if(known(n,iper,teq).eq.1) goto 10 + itry=itry+1 + if(itry.gt.icen) return + do 20 i=1,iper + 20 xp(i)=x(n-iper+i) + call snls1(peri,1,iper,iper,xp,fvec,w0,mper,tol,tol,0., + . 20*(iper+1),0.,w1,1,100.,0,info,nfev,ndum,iw,w2,w3,w4,w5,w6) + err=enorm(iper,fvec) + if(info.eq.-1.or.info.eq.5.or.err.gt.tacc) goto 10 ! unsuccessfull + if(isold(iper,xp,ior,xor,tdis).eq.1) goto 10 ! already found + ior=ior+1 ! a new orbit + do 30 i=1,iper + 30 xor(i,ior)=xp(i) + ipor=iperiod(iper,xp,tdis) + sor=ipor*stab(iper,xp,h)/real(iper) + call print(iper,xp,ipor,sor,err,iunit,iverb) + 10 continue + end + + function known(n,iper,tol) +c return 1 if equivalent starting point has been tried + parameter(nx=1000000) + dimension x(nx) + common /period/ x, nmax, m, eps + + known=1 + do 10 nn=iper,n-1 + dis=0 + do 20 i=1,iper + 20 dis=dis+(x(n-iper+i)-x(nn-iper+i))**2 + 10 if(sqrt(dis).lt.tol) return + known=0 + end + + function isold(iper,xp,ior,xor,toler) +c determine if orbit is in data base + parameter(mper=20) + dimension xp(iper), xor(mper,*) + + isold=1 + do 10 ip=1,iper + do 20 io=1,ior + dor=0 + do 30 i=1,iper + 30 dor=dor+(xp(i)-xor(i,io))**2 + 20 if(sqrt(dor).le.toler) return + 10 call oshift(iper,xp) + isold=0 + end + + subroutine oshift(iper,xp) +c leftshift orbit circularly by one position + dimension xp(*) + + h=xp(1) + do 10 i=1,iper-1 + 10 xp(i)=xp(i+1) + xp(iper)=h + end + + function iperiod(iper,xp,tol) +c determine shortest subperiod + dimension xp(*) + + do 10 iperiod=1,iper + dis=0 + do 20 i=1,iper + il=i-iperiod + if(il.le.0) il=il+iper + 20 dis=dis+(xp(i)-xp(il))**2 + 10 if(sqrt(dis).le.tol) return + end + + subroutine peri(iflag,mf,iper,xp,fvec,fjac,ldfjac) +c built discrepancy vector (as called by snls1) + dimension xp(*),fvec(*) + + do 10 ip=1,iper + fvec(ip)=xp(1)-fc(iper,xp,iflag) + 10 call oshift(iper,xp) + end + + function fc(iper,xp,iflag) +c predict (cyclic) point 1, using iper,iper-1... + parameter(nx=1000000) + dimension xp(*), x(nx) + common /period/ x, nmax, m, eps + data cut/20/ + + eps2=1./(2*eps*eps) + ft=0 + sw=0 + fc=0 + do 10 n=m+1,nmax + dis=0 + do 20 i=1,m + 20 dis=dis+(x(n-i)-xp(mod(m*iper-i,iper)+1))**2 + ddis=dis*eps2 + w=0 + if(ddis.lt.cut) w=exp(-ddis) + ft=ft+w*x(n) + 10 sw=sw+w + iflag=-1 + if(sw.eq.0) return ! fc undefined, stop minimising + fc=ft/sw + iflag=1 + end + + function stab(ilen,xp,h) +c compute cycle stability by iteration of a tiny perturbation + parameter(nx=1000000,mper=20,maxit=1000) + dimension xp(*), x(nx), xcop(mper) + common /period/ x, nmax, m, eps + + if(mper.lt.ilen) stop "stability: make mper larger." + iflag=1 + stab=0 + do 10 i=2,m + 10 xcop(i)=xp(mod(i-1,ilen)+1) + xcop(1)=xp(1)+h + do 20 it=1,maxit + do 30 itt=1,ilen + xx=fc(m,xcop,iflag) + if(iflag.eq.-1) goto 1 + call oshift(m,xcop) + 30 xcop(m)=xx + dis=0 + do 40 i=1,m + 40 dis=dis+(xcop(i)-xp(mod(i-1,ilen)+1))**2 + dis=sqrt(dis) + stab=stab+log(dis/h) + do 20 i=1,m + 20 xcop(i)=xp(mod(i-1,ilen)+1)*(1-h/dis) + xcop(i)*h/dis + 1 stab=stab/max(it-1,1) + end + + subroutine print(iper,xp,ipor,sor,err,iunit,iverb) +c write orbit to iunit and to stdout + dimension xp(*) + + write(iunit,*) + write(iunit,*) "period / accuracy / stability" + write(iunit,*) ipor, err, exp(sor) + do 10 i=1,ipor + 10 write(iunit,*) i, xp(i) + if(iv_upo(iverb).eq.0) return + write(istderr(),*) + write(istderr(),*) "period / accuracy / stability" + write(istderr(),*) ipor, err, exp(sor) + do 20 i=1,ipor + 20 write(istderr(),*) i, xp(i) + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/upoembed.f b/binaries/src/disembl/Tisean_3.0.1/source_f/upoembed.f new file mode 100644 index 0000000..cd560b9 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/upoembed.f @@ -0,0 +1,69 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c delay coordinates for periodic orbits +C Copyright (C) Thomas Schreiber (1998) +c=========================================================================== + parameter(nx=1000) + dimension x(nx) + character*72 file, fout + data m/2/ + data iverb/1/ + + call whatido("embed using delay coordinates",iverb) + id=imust("d") + m=ican("m",m) + ipp=ican("p",0) + isout=igetout(fout,iverb) + call nthstring(1,file) + call infile(file,iunit,iverb) + if(isout.eq.1) call addsuff(fout,file,"_delay") + call outfile(fout,iunit2,iverb) + + 1 read(iunit,*,err=1,end=999) ipor, dum1, dum2 + do 10 ip=1,ipor + 10 read(iunit,*,end=999) idum, x(ip) + if(ipp.ne.0.and.ipor.ne.ipp) goto 1 + do 20 ip=1,ipor+1 + 20 write(iunit2,*) (x(mod(ip-(j-1)*id-1+m*ipor,ipor)+1), j=m,1,-1) + write(iunit2,'()') + write(iunit2,'()') + goto 1 + 999 continue + end + + subroutine usage() +c usage message + + call whatineed( + . "-d# [-m# -p# -o outfile -l# -x# -c# -V# -h] file") + call popt("d","delay") + call popt("m","embedding dimension (2)") + call popt("p","period of orbit (1)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_delay") + call pall() + stop + end + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/verbose.f b/binaries/src/disembl/Tisean_3.0.1/source_f/verbose.f new file mode 100644 index 0000000..6d7263d --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/verbose.f @@ -0,0 +1,98 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c utilities for TISEAN f-sources +c=========================================================================== + function igetv(idef) +c get verbosity level + + igetv=ican("V",-1) + if(igetv.eq.-1.and.lopt("V",1).eq.1) igetv=2**15-1 + if(igetv.eq.-1) igetv=idef + end + + function iexv(iverb,item) +c 1 if verbosity level includes item + + iexv=iand(iverb,item)/item + end + +c the following functions test for specific numerical verbosity values + + function iv_io(iverb) ! report i/o activity + iv_io=iexv(iverb,1) + end + + function iv_echo(iverb) ! echo first line of data read + iv_echo=iexv(iverb,128) + end + + function iv_cost(iverb) ! current value of cost function + iv_cost=iexv(iverb,2) + end + + function iv_match(iverb) ! cost mismatch + iv_match=iexv(iverb,4) + end + + function iv_cool(iverb) ! temperature etc. at cooling + iv_cool=iexv(iverb,8) + end + + function iv_vcost(iverb) ! verbose cost if improved + iv_vcost=iexv(iverb,16) + end + + function iv_vmatch(iverb) ! verbose cost mismatch + iv_vmatch=iexv(iverb,32) + end + + function iv_10(iverb) ! upo status after 10 points + iv_10=iexv(iverb,16) + end + + function iv_100(iverb) ! upo status after 100 points + iv_100=iexv(iverb,8) + end + + function iv_1000(iverb) ! upo status after 1000 points + iv_1000=iexv(iverb,4) + end + + function iv_upo(iverb) ! print orbits found + iv_upo=iexv(iverb,2) + end + + function iv_surr(iverb) ! print iterations / discrepancy + iv_surr=iexv(iverb,2) + end + + function iv_uncorr(iverb) ! neighbour search status + iv_uncorr=iexv(iverb,2) + end + + function iv_clust(iverb) ! clustering status + iv_clust=iexv(iverb,2) + end + + + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/wiener1.f b/binaries/src/disembl/Tisean_3.0.1/source_f/wiener1.f new file mode 100644 index 0000000..0b5d9a2 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/wiener1.f @@ -0,0 +1,85 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c Wiener filter (1): write periodogram to file +c author T. Schreiber (1998) +c=========================================================================== + parameter(nx=1000000) + dimension x(nx) + character*72 file, fout + data h/1./, dh/0./ + data iverb/1/ + + call whatido("Wiener filter (first part)",iverb) + h=fcan("f",h) + dh=fcan("w",dh) + nmax=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + isout=igetout(fout,iverb) + + call nthstring(1,file) + if(file.eq."-") stop "wiener1: cannot read stdin" + call readfile(nmax,x,nexcl,jcol,file,iverb) + call normal(nmax,x,sc,sd) + nmaxp=nmore(nmax) + if(nmaxp.ne.nmax) then + write(istderr(),*) "wiener1: padding zeroes to ", nmaxp + do 10 n=nmax+1,nmaxp + 10 x(n)=0. + endif + if(isout.eq.1) call addsuff(fout,file,"_amp") + call outfile(fout,iunit,iverb) + if(dh.eq.0.) dh=h/nmaxp + ibin=nmaxp*dh/(2*h) + if(ibin.gt.0) write(istderr(),*) + . "wiener1: binning", 2*ibin+1," frequencies" + call store_spec(nmaxp,x,0) + write(iunit,*) 0., x(1) + do 20 i=2+ibin,(nmaxp+1)/2-ibin,2*ibin+1 + p=0 + do 30 ib=i-ibin,i+ibin + 30 p=p+x(2*ib-2) + 20 write(iunit,*) h*(i-1)/real(nmaxp), p + if(mod(nmaxp,2).eq.0) write(iunit,*) + . h*(nmaxp-1)/real(nmaxp), x(nmaxp) + if(iunit.ne.istdout()) write(istderr(),*) + . 'Now edit periodogram in file ', fout(1:index(fout," ")-1) + end + + subroutine usage() +c usage message + + call whatineed( + . "[-f# -w# -o outfile -l# -x# -c# -V# -h] file") + call ptext("then edit file_amp and run: "// + . "wiener2 [-f# -w# -o outfile -l# -x# -c# -V# -h] file") + call popt("f","sampling rate (e.g. in Hz, default 1.)") + call popt("w","frequency resolution (e.g. in Hz, default 1/N)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call pout("file_amp") + call pall() + call ptext("Note: ""-"" not accepted as file") + write(istderr(),'()') + stop + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/wiener2.f b/binaries/src/disembl/Tisean_3.0.1/source_f/wiener2.f new file mode 100644 index 0000000..41e8324 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/wiener2.f @@ -0,0 +1,95 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c Wiener filter (2): filter using periodogram in file +c author T. Schreiber (1998) +c=========================================================================== + parameter(nx=1000000) + dimension x(nx), a(nx) + character*72 file, fout, ffin + data h/1./, dh/0./ + data iverb/1/ + + call whatido("Wiener filter (second part)",iverb) + h=fcan("f",h) + dh=fcan("w",dh) + nmax=ican("l",nx) + nexcl=ican("x",0) + jcol=ican("c",0) + isfin=igetfin(ffin,iverb) + isout=igetout(fout,iverb) + call nthstring(1,file) + if(file.eq."-") stop "wiener2: cannot read stdin" + call readfile(nmax,x,nexcl,jcol,file,iverb) + call normal(nmax,x,sc,sd) + nmaxp=nmore(nmax) + + if(dh.eq.0.) dh=h/nmaxp + ibin=nmaxp*dh/(2*h) + if(ibin.gt.0) write(istderr(),*) + . "wiener1: binning", 2*ibin+1," frequencies" + if(isout.eq.1) call addsuff(fout,file,"_amp") + if(fout.eq." ") fout="-" + call infile(fout,iunit,iverb) + read(iunit,*) dum, a(1) + do 10 i=2+ibin,(nmaxp+1)/2-ibin,2*ibin+1 + 10 read(iunit,*) dum, a(2*i-2) + if(mod(nmaxp,2).eq.0) read(iunit,*) + . dum, a(nmaxp) + d=tospec(nmaxp,a,x,ibin) + if(iv_io(iverb).eq.1) write(istderr(),*) "rms correction: ", d + if(isfin.eq.1) call addsuff(ffin,file,"_wc") + do 20 n=1,nmax + 20 x(n)=x(n)+sc + call writefile(nmax,x,ffin,iverb) + end + + subroutine usage() +c usage message + + call whatineed( + . "[-f# -w# -o outfile1 -O outfile -l# -x# -c# -V# -h] file") + call ptext("to provide periodogram, first run:"// + . " wiener1 [-f# -w# -o outfile -l# -x# -c# -V# -h] file") + call ptext("make sure -f# -w# are the same in both wiener calls") + call popt("f","sampling rate (e.g. in Hz, default 1.)") + call popt("w","frequency resolution (e.g. in Hz, default 1/N)") + call popt("l","number of values to be read (all)") + call popt("x","number of values to be skipped (0)") + call popt("c","column to be read (1 or file,#)") + call popt("o","output file of wiener1, just -o means file_amp") + call popt("O","final output file name, just -O means file_wc") + call pall() + call ptext("Note: ""-"" not accepted as file") + write(istderr(),'()') + stop + end + + function igetfin(fout,iverb) +c gets alternate output file name, default " " +c return 1 if fout must be determined from input file name + character*(*) fout + + igetfin=0 + call stcan("O",fout," ") + if(fout.ne." ") return + igetfin=lopt("O",1) + end diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/xc2.f b/binaries/src/disembl/Tisean_3.0.1/source_f/xc2.f new file mode 100644 index 0000000..86917a8 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/xc2.f @@ -0,0 +1,244 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c========================================================================= +c +c cross-correlation integral xc2 +c see H. Kantz, Phys.Rev.E49, 5091 (1994) +c +c authors: T. Schreiber & H. Kantz (1998) +c multivariate version: H. Kantz (Jan 2007) +c +c========================================================================= +c + parameter(nx=1000000,me=30,meps=1000,mx=10) + dimension x(nx,mx), c(me,meps), eps(meps), mdeps(meps), icol(mx) + dimension y(nx,mx) + integer mlist(2) + character*72 file1, file2, fout + data ipmin/1000/, res/2./, eps0/1e-30/, epsm/1e30/, id0/1/ + data iverb/1/ + +c======================================================================= +c assume two input files (file1, file2) +c - with identical structure in terms of colums +c - with identical embedding spaces +c - with individual length and exclusions: l, L, x, X +c - multivariate data: maximum length nx, maximum dimension mx +c +c norm: max-norm +c +c no rescaling, since xc2 does not make sense if datasets are +c not used in their original scalings +c================================================================= + + call whatido("cross correlation sum of two data sets",iverb) + id=ican("d",id0) + mmax=2 + mdim=1 + + call imcan("M",2,mc,mlist) + if (mc.ge.2) then + mmax=mlist(2) + mdim=mlist(1) + if (mmax*mdim.lt.2) stop 'Increase embedding dimension' + if (mc.gt.2) print*, 'extra arguments of -m ignored' + endif + + ntmin=0 + ncmin=ican("n",1000) + ipmin=ican("N",ipmin) + res=fcan("#",res) + feps=2**(1./res) + eps0=fcan("r",eps0) + epsm=fcan("R",epsm) + nmaxx=ican("l",nx) + nmaxy=ican("L",nx) + nexcl1=ican("x",0) + nexcl2=ican("X",0) + + call columns(mc,mx,icol) + + if (mc.gt.0.and.mc.ne.mdim) stop 'improper number of columns' + isout=igetout(fout,0) + if(fout.eq." ") isout=1 + + call nthstring(1,file1) + if(file1.eq."-") stop "first input file name missing" + call xreadfile(nmaxx,mdim,nx,x,nexcl1,icol,file1,iverb) + call nthstring(2,file2) + if(file2.eq."-") stop "second input file name missing" + call xreadfile(nmaxy,mdim,nx,y,nexcl2,icol,file2,iverb) + + if(isout.eq.1) then + call addsuff(fout,file1,"_") + call addsuff(fout,fout,file2) + call addsuff(fout,fout,"_xc2") + endif + + epsmax=0. + do imx=1,mmax + call minmax(nmaxx,x(1,imx),xmin,xmax) + epsmax=1.001*max(xmax-xmin,epsmax) + enddo + do imx=1,mmax + call minmax(nmaxy,y(1,imx),xmin,xmax) + epsmax=1.001*max(xmax-xmin,epsmax) + enddo + + neps=0 + + do 10 epsl=log(min(epsm,epsmax)),log(eps0),-log(feps) + neps=neps+1 + if(neps.gt.meps) stop "xc2: make meps larger" + eps(neps)=exp(epsl) + do 20 m=1,mmax*mdim + 20 c(m,neps)=0 + if (mdim.eq.1) then + call crosscor(nmaxx,x,nmaxy,y,eps(neps) + . ,id,mmax,c(1,neps),ncmin,ipmin) + else + call mcrosscor(nmaxx,x,nmaxy,y,eps(neps), + . id,mmax,mdim,c(1,neps),ncmin,ipmin) + endif + mdd=mmax*mdim + mdd1=max(2,mdim) + do 30 m=mdd1,mdd + 30 if(c(m,neps).eq.0.) goto 1 + m=mdd+1 + 1 mdd=m-1 + if(mdd.eq.mdim-1) stop + mdeps(neps)=mdd + call outfile(fout,iunit,iverb) + do 40 m=mdd1,mdeps(1) + write(iunit,'(4h#m= ,i5)') m + do 50 nn=1,neps + if(mdeps(nn).lt.m) goto 2 + 50 write(iunit,*) eps(nn), c(m,nn) + 2 write(iunit,'()') + 40 write(iunit,'()') + close(iunit) + 10 write(istderr(),*) eps(neps), mdd, c(mdd,neps) + stop + end +c>-------------------------------------------------------------------- + subroutine usage() +c usage message + + call whatineed( + . "-M#,# [-d# -n# -N# -## -r# -R#"// + . " -o outfile -l# -x# -L# -X# -c#[,#] -V# -h] file1 file2") + call popt("M", + ."# of components, maximal embedding dimension [1,2]") + call popt("d","delay [1]") + call popt("n","minimal number of center points [1000]") + call popt("N","maximal number of pairs [1000]") + call popt("#","resolution, values per octave [2]") + call popt("r", + . "minimal scale to be probed (as long as pairs found)") + call popt("R","maximal scale to be probed [xmax-xmin]") + call popt("l","length of time series 1 to be read [all data]") + call popt("x","# of initial lines of 1 to be skipped [0]") + call popt("L","length of time series 2 to be read [all data]") + call popt("X","# of initial lines of 2 to be skipped [0]") + call popt("c", + ."columns to be read [1,2,3,.., # of components]") + call pout("file1_file2_xc2") + call pall() + stop + end +c>-------------------------------------------------------------------- + subroutine crosscor(nmaxx,x,nmaxy,y,eps,id,m,c,ncmin,ipmin) + parameter(im=100,ii=100000000,nx=1000000,mm=30) + dimension y(nmaxy),x(nmaxx) + dimension jh(0:im*im),ipairs(mm),c(m),jpntr(nx),nlist(nx) + + if(nmaxx.gt.nx.or.m.gt.mm) stop "crosscor: make mm/nx larger." + if(nmaxy.gt.nx.or.m.gt.mm) stop "crosscor: make mm/nx larger." + + do 10 i=1,m-1 + 10 ipairs(i)=0 + mb=min(m,2) + call base(nmaxx,x,id,mb,jh,jpntr,eps) + do 20 n=(m-1)*id+1,nmaxy + call neigh(nx,y,x,n,nmaxx,id,mb,jh,jpntr,eps,nlist,nfound) + do 30 nn=1,nfound ! all neighbours in two dimensions + np=nlist(nn) + if(np.lt.(m-1)*id+1) goto 30 + ipairs(1)=ipairs(1)+1 + do 40 i=mb,m-1 + if(abs(y(n-i*id)-x(np-i*id)).ge.eps) goto 30 + 40 ipairs(i)=ipairs(i)+1 ! neighbours in 3..m dimensions + 30 continue + 20 if(n-(m-1)*id.ge.ncmin.and.ipairs(m-1).ge.ipmin) goto 1 + n=n-1 + 1 s=real(n-(m-1)*id)*real(nmaxx-(m-1)*id) ! normalisation + do 50 i=1,m-1 + 50 if(s.gt.0.) c(i+1)=ipairs(i)/s + end +c>-------------------------------------------------------------------- + subroutine mcrosscor(nmaxx,x,nmaxy,y,eps,id,m,mdim,c,ncmin,ipmin) + + parameter(im=100,nx=1000000,mm=30,mx=10) + + dimension y(nx,mx),x(nx,mx) + dimension jh(0:im*im),ipairs(mm),c(m*mdim),jpntr(nx),nlist(nx) + dimension vx(mm) + + if(nmaxx.gt.nx.or.m.gt.mm) stop "mcrosscor: make mm/nx larger." + if(nmaxy.gt.nx.or.m.gt.mm) stop "mcrosscor: make mm/nx larger." + + if (m*mdim.gt.mm) stop 'embedding x spatial dimension < 30 !' + do 10 i=1,m*mdim + 10 ipairs(i)=0 + + call mbase(nmaxy,mdim,nx,y,id,1,jh,jpntr,eps) + do 20 n=(m-1)*id+1,nmaxx + do ii=1,mdim + vx(ii)=x(n,ii) + enddo + call mneigh2(nmaxy,mdim,y,nx,vx,jh,jpntr,eps,nlist,nfound) + do 30 nn=1,nfound ! all neighbours in mdim dimensions + np=nlist(nn) + if(np.lt.(m-1)*id+1) goto 30 + ipairs(mdim)=ipairs(mdim)+1 + do 40 i=1,m-1 + do 41 iim=1,mdim + if(abs(x(n-i*id,iim)-y(np-i*id,iim)).ge.eps) goto 30 + idim=i*mdim+iim + ipairs(idim)=ipairs(idim)+1 ! neighbours mdim+1..m dimensions + 41 continue + 40 continue + 30 continue + 20 if(n-(m-1)*id.ge.ncmin.and.ipairs(m*mdim).ge.ipmin) goto 1 + n=n-1 + 1 s=real(n-(m-1)*id)*real(nmaxy-(m-1)*id) ! normalisation + do 50 i=mdim,mdim*m + 50 if(s.gt.0.) c(i)=ipairs(i)/s + + return + end +c>--------------------------------------------------------------------- + + + + + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/xreadfile.f b/binaries/src/disembl/Tisean_3.0.1/source_f/xreadfile.f new file mode 100644 index 0000000..65daaa8 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/xreadfile.f @@ -0,0 +1,103 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c multivariate i/o utilities for TISEAN f-sources +c author T. Schreiber (1999) +c=========================================================================== + subroutine xreadfile(nmax,mmax,nx,x,nexcl,icol,file,iverb) +c read columns as seperate time series + parameter(mline=1000) + dimension x(nx,mmax), icol(mmax), dum(mline) + character*(*) file + + iv=iv_io(iverb) + if(iv.ne.0) write(istderr(),*) + . 'reading from columns', (icol(i),i=1,mmax) + call infile(file,iunit,iverb) + mlast=0 + do 10 i=1,mmax + 10 mlast=max(mlast,icol(i)) + if(mlast.gt.mline) stop "xreadfile: make mline larger." + lc=0 + do 20 n=1,nexcl + lc=lc+1 + 20 read(iunit,*,end=999) + do 30 n=1,nmax + 1 lc=lc+1 + read(iunit,*,err=2,end=999) (dum(i),i=1,mlast) + do 40 i=1,mmax + 40 x(n,i)=dum(icol(i)) + goto 30 + 2 if(iv.ne.0) write(istderr(),*) "data in line ", lc, " ignored" + goto 1 + 30 continue + if(iv.ne.0) write(istderr(),*) '*** readfile: warning:'// + . ' maybe not the whole file has been used' + 999 nmax=n-1 + if(iunit.ne.istdin()) close(iunit) + if(iv.ne.0) call readreport(nmax,file) + end + + subroutine xwritecfile(nmax,mmax,nx,x,file,iverb,comm) +c write comment and nmax points + dimension x(nx,mmax) + character*(*) file,comm + + if(mmax.gt.1000) then + write(istderr(),*) "xwritecfile: "// + . "cannot write more than 1000 columns" + stop + endif + call outfile(file,iunit,iverb) + if(comm.ne." ") write(iunit,'(a)') comm + do 10 n=1,nmax + 10 write(iunit,'(1000g16.7)') (x(n,i),i=1,mmax) + if(iunit.eq.istdout()) then + write(iunit,*) + write(iunit,*) + else + close(iunit) + endif + if(iv_io(iverb).eq.1) call writereport(nmax,file) + end + + subroutine xwritefile(nmax,mmax,nx,x,file,iverb) +c write nmax points + dimension x(nx,mmax) + character*(*) file + + call xwritecfile(nmax,mmax,nx,x,file,iverb," ") + end + + subroutine columns(mc,mmax,icol) + dimension icol(*) + + call imcan("c",mmax,mc,icol) + icmax=0 + do 10 m=1,mc + 10 icmax=max(icmax,icol(m)) + do 20 m=mc+1,mmax + icmax=icmax+1 + 20 icol(m)=icmax + end + + + diff --git a/binaries/src/disembl/Tisean_3.0.1/source_f/xrecur.f b/binaries/src/disembl/Tisean_3.0.1/source_f/xrecur.f new file mode 100644 index 0000000..75c8d95 --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/source_f/xrecur.f @@ -0,0 +1,402 @@ +c=========================================================================== +c +c This file is part of TISEAN +c +c Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber +c +c TISEAN is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c TISEAN is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with TISEAN; if not, write to the Free Software +c Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +c +c=========================================================================== +c cross-recurrence plot +c authors H. Kantz & T. Schreiber (2004) +c modified by H. Kantz Feb 2007 (multivariate version) + program xrecur + parameter(nx=1000000,me=30,meps=1000,mx=10,nx1=10000000) + dimension x(nx,mx), y(nx,mx) + dimension x1(nx1),y1(nx1) + integer mlist(2), inot(nx1), icol(mx) + character*72 file1, file2, fout + data eps/1e-3/, id0/1/ + data iverb/1/, xperc/100./ + + call whatido( + ."cross recurrence plot of two scalar or vector valued data sets" + . ,iverb) + +c ================================================================ +c assume two input files (file1, file2) +c - with identical structure in terms of colums +c - with identical embedding spaces +c - with individual length and exclusions: l1,l2, x1,x2 +c - univariate data: maximum time series length nx1 +c - multivariate data: maximum length nx, maximum dimension mx +c +c either: fixed epsilon, plot certain percentage of all +c neighbours found +c or: fix the numbers of points of the y time series to be +c found as neighbours of the x time series: non-symmetric! +c norm: max-norm after rescaling of the individual components +c unless rescaling is switched off +c +c================================================================= + + id=ican("d",id0) + + mmax=2 + mdim=1 + + call imcan("m",2,mc,mlist) + if (mc.ge.2) then + mmax=mlist(2) + mdim=mlist(1) + if (mc.gt.2) print*,'extra arguments of -m ignored' + endif + ntmin=0 + kmin=ican("k",0) + idown1=ican("s",1) + idown2=ican("S",1) + eps=fcan("r",eps) + xperc=fcan("%",xperc) + nmaxx=ican("l",nx) + nmaxy=ican("L",nx) + nexcl1=ican("x",0) + nexcl2=ican("X",0) + iscal=0 + iscal=lopt("n",1) + + call columns(mc,mx,icol) + if (mc.gt.0.and.mc.ne.mdim) stop 'improper number of columns' + isout=igetout(fout,0) + if(fout.eq." ") isout=1 +c + call nthstring(1,file1) + if(file1.eq."-") stop 'missing input filename' + if (mdim.gt.1) + . call xreadfile(nmaxx,mdim,nx,x,nexcl1,icol,file1,iverb) + if (mdim.eq.1) + . call xreadfile(nmaxx,1,nx1,x1,nexcl1,icol,file1,iverb) +c + call nthstring(2,file2) + if(file2.eq."-") stop 'missing second input filename' + if (mdim.gt.1) + . call xreadfile(nmaxy,mdim,nx,y,nexcl2,icol,file2,iverb) + if (mdim.eq.1) + . call xreadfile(nmaxy,1,nx1,y1,nexcl2,icol,file2,iverb) + + if(isout.eq.1) then + call addsuff(fout,file1,"_") + call addsuff(fout,fout,file2) + call addsuff(fout,fout,"_xrec") + endif + +c rescale data if flag -n is not set (iscal=1) + if (iscal.ne.1) then + print*,'normalizing data to unit interval' + + if (mdim.gt.1) then + +c rescaling each component of file 1 + do imx=1,mdim + xmin=x(1,imx) + xmax=x(1,imx) + do i1=2,nmaxx + xmax=max(xmax,x(i1,imx)) + xmin=min(xmin,x(i1,imx)) + enddo + scal=.9999d0/(xmax-xmin) + do i1=1,nmaxx + x(i1,imx)=(x(i1,imx)-xmin)*scal + enddo + enddo + +c rescaling each component of file 2 + + do imx=1,mdim + xmin=y(1,imx) + xmax=y(1,imx) + do i1=2,nmaxy + xmax=max(xmax,y(i1,imx)) + xmin=min(xmin,y(i1,imx)) + enddo + scal=.9999d0/(xmax-xmin) + do i1=1,nmaxy + y(i1,imx)=(y(i1,imx)-xmin)*scal + enddo + enddo + + else + +c rescaling the single component of file 1 + xmin=x1(1) + xmax=x1(1) + do i1=2,nmaxx + xmax=max(xmax,x1(i1)) + xmin=min(xmin,x1(i1)) + enddo + scal=.9999d0/(xmax-xmin) + do i1=1,nmaxx + x1(i1)=(x1(i1)-xmin)*scal + enddo + +c rescaling the single component of file 2 + + xmin=y1(1) + xmax=y1(1) + do i1=2,nmaxy + xmax=max(xmax,y1(i1)) + xmin=min(xmin,y1(i1)) + enddo + scal=.9999d0/(xmax-xmin) + do i1=1,nmaxy + y1(i1)=(y1(i1)-xmin)*scal + enddo + + endif + endif + + call outfile(fout,iunit,1) + ntot=0 + + if (kmin.eq.0) then +c search all neighbours with distance < eps + + xperc=xperc/100. + + if (mdim.eq.1) then + call crossrec(nmaxx,x1,nmaxy,y1,eps, + . id,mmax,iunit,xperc,ntot,idown1,idown2) + else + call mcrossrec(nmaxx,x,nmaxy,y,eps, + . id,mmax,mdim,iunit,xperc,ntot,idown1,idown2) + endif + +c>----------------------------------------------------------- + else + + do i=(mmax-1)*id+1,nmaxx + inot(i)=1 + enddo + epsfac=1.1 + eps=eps/epsfac + + do 10 io=1,100 + eps=eps*epsfac + if (mdim.eq.1) then + call crossrec1(nmaxx,x1,nmaxy,y1,eps, + . id,mmax,kmin,iunit,inot,ntodo,ntot,idown1,idown2) + else + call mcrossrec1(nmaxx,x,nmaxy,y,eps,id,mmax,mdim,kmin,iunit, + . inot,ntodo,ntot,idown1,idown2) + endif + if (iverb.eq.1) print*,eps,ntodo,ntot + if (ntodo.eq.0) goto 7 + 10 continue +c>-------------------------------------------------------- + endif + + 7 close(iunit) + print*,ntot,' points contained in the recurrence plot' + if (kmin.gt.0) print*,'last epsilon:',eps + if (kmin.gt.0) print*,'average number of neighbours:', + . real(ntot)*idown1/nmaxx + if (kmin.eq.0) print*,'using eps=',eps + end +c======================================================== + subroutine usage() +c usage message + + call whatineed( + ."[ -m#,# -d# -r# -k# -o outfile -l# -x# -L# -X# -c#[,#] -%# -V# + . -n -h] file1 file2") + call popt("m","# of components, embedding dimension [1,2]") + call popt("c","columns to be read [1,2,3,...,# of components]") + call popt("d","delay [1]") + call popt("r", + ."diameter of the neighbourhood as absolute value [.001]") + call popt("k", + ."find the # closest points, starting with diameter r") + call popt("%", + ."print only percentage of dots [100], no effect if -k is set") + call popt("l","length of time series 1 to be read [all data]") + call popt("x","# of initial lines in 1 to be skipped [0]") + call popt("s","use only every # delay vector of file 1 [1]") + call popt("L","length of time series 2 to be read [all data]") + call popt("X","# of initial lines in 2 to be skipped [0]") + call popt("S","use only every # delay vector of file 2 [1]") + call popt("n","if set: do NOT normalize data to unit interval") + call pout("file1_file2_xrec") + call pall() + stop + end +c>-------------------------------------------------------------------- + subroutine crossrec(nmaxx,x,nmaxy,y,eps, + . id,m,iunit,xperc,ntot,idown1,idown2) + parameter(im=100,ii=100000000,nx=1000000) + dimension y(nx),x(nx) + dimension jh(0:im*im),jpntr(nx),nlist(nx) + nseed=13413241 + + if(nmaxx.gt.nx.or.nmaxy.gt.nx) stop "crossrec: make nx larger." + mb=min(m,2) + + call base(nmaxy,y,id,mb,jh,jpntr,eps) + nnull=(m-1)*id+1 + do 20 n=nnull,nmaxx,idown1 + call neigh(nx,x,y,n,nx,id,mb,jh,jpntr,eps,nlist,nfound) + do 30 nn=1,nfound ! all neighbours in two dimensions + np=nlist(nn) + if (np.lt.nnull) goto 30 + if (mod(np-nnull,idown2).ne.0) goto 30 + do 40 i=mb,m-1 + if(abs(x(n-i*id)-y(np-i*id)).ge.eps) goto 30 + 40 continue + call random(nseed,rr) + if (rr.le.xperc) write(iunit,*)n,np + if (rr.le.xperc) ntot=ntot+1 + 30 continue + 20 continue + end +c>-------------------------------------------------------------------- + subroutine mcrossrec(nmaxx,x,nmaxy,y,eps, + . id,m,mdim,iunit,xperc,ntot,idown1,idown2) + parameter(im=100,nx=1000000,mx=10) + dimension y(nx,mx),x(nx,mx) + dimension jh(0:im*im),jpntr(nx),nlist(nx) + dimension vx(mx) + nseed=134512331 + + if(nmaxx.gt.nx.or.nmaxy.gt.nx) stop "mcrossrec: make nx larger." + + call mbase(nmaxy,mdim,nx,y,id,1,jh,jpntr,eps) + nnull=(m-1)*id+1 + do 20 n=nnull,nmaxx,idown1 + do ii=1,mdim + vx(ii)=x(n,ii) + enddo + call mneigh2(nmaxy,mdim,y,nx,vx,jh,jpntr,eps,nlist,nfound) + do 30 nn=1,nfound ! all neighbours in mdim dimensions + np=nlist(nn) + if (np.lt.nnull) goto 30 + if (mod(np-nnull,idown2).ne.0) goto 30 + do 40 i=1,m-1 + do 41 iim=1,mdim + if(abs(x(n-i*id,iim)-y(np-i*id,iim)).ge.eps) goto 30 + 41 continue + 40 continue + call random(nseed,rr) + if (rr.le.xperc) write(iunit,*)n,np + if (rr.le.xperc) ntot=ntot+1 + 30 continue + 20 continue + return + end + + subroutine crossrec1(nmaxx,x,nmaxy,y,eps,id,m,kmin,iunit, + . inot,ntodo,ntot,idown1,idown2) + parameter(im=100,ii=100000000,nx=1000000) + dimension y(nmaxy),x(nmaxx),inot(nmaxx) + dimension jh(0:im*im),jpntr(nx),nlist(nx) + ntodo=0 + + if(nmaxx.gt.nx.or.nmaxy.gt.nx) stop "crossrec1: make nx larger." + mb=min(m,2) + + call base(nmaxy,y,id,mb,jh,jpntr,eps) + nnull=(m-1)*id+1 + do 20 n=nnull,nmaxx,idown1 + if (inot(n).eq.0) goto 20 + ntodo=ntodo+1 + call neigh(nx,x,y,n,nx,id,mb,jh,jpntr,eps,nlist,nfound) + if (nfound.lt.kmin) goto 20 + nreal=0 + do 30 nn=1,nfound ! all neighbours in two dimensions + np=nlist(nn) + if(np.lt.nnull) goto 30 + if (mod(np-nnull,idown2).ne.0) goto 30 + do 40 i=mb,m-1 + if(abs(x(n-i*id)-y(np-i*id)).ge.eps) goto 30 + 40 continue + nreal=nreal+1 + nlist(nreal)=np + 30 continue + if (nreal.lt.kmin) goto 20 + ntodo=ntodo-1 + inot(n)=0 + ntot=ntot+nreal + do in=1,nreal + write(iunit,*)n,nlist(in) + enddo + 20 continue + end +c>-------------------------------------------------------------------- + subroutine mcrossrec1(nmaxx,x,nmaxy,y,eps, + . id,m,mdim,kmin,iunit,inot, + . ntodo,ntot,idown1,idown2) + parameter(im=100,nx=1000000,mx=10) + dimension y(nx,mx),x(nx,mx),inot(nmaxx) + dimension jh(0:im*im),jpntr(nx),nlist(nx) + dimension vx(mx) + ntodo=0 + + if(nmaxx.gt.nx.or.nmaxy.gt.nx) stop "mcrossrec1: make nx larger." + + call mbase(nmaxy,mdim,nx,y,id,1,jh,jpntr,eps) + nnull=(m-1)*id+1 + do 20 n=nnull,nmaxx,idown1 + if (inot(n).eq.0) goto 20 + ntodo=ntodo+1 + do ii=1,mdim + vx(ii)=x(n,ii) + enddo + call mneigh2(nmaxy,mdim,y,nx,vx,jh,jpntr,eps,nlist,nfound) + if (nfound.lt.kmin) goto 20 + nreal=0 + do 30 nn=1,nfound ! all neighbours in mdim dimensions + np=nlist(nn) + if(np.lt.nnull) goto 30 + if (mod(np-nnull,idown2).ne.0) goto 30 + do 40 i=0,m-1 + do 41 iim=1,mdim + if(abs(x(n-i*id,iim)-y(np-i*id,iim)).ge.eps) goto 30 + 41 continue + 40 continue + nreal=nreal+1 + nlist(nreal)=np + 30 continue + if (nreal.lt.kmin) goto 20 + inot(n)=0 + ntot=ntot+nreal + do in=1,nreal + write(iunit,*)n,nlist(in) + enddo + ntodo=ntodo-1 + 20 continue + return + end + + subroutine random(iseed,s) +c +c random number generator of Park & Miller + integer*8 ifac,ibase,iargument + ifac=7**5 + ibase=2**30-1 + im=im+2**30 + iargument=iseed + iargument=mod(iargument*ifac,ibase) + s=float(iargument)/float(ibase) + iseed=iargument + return + end +c>------------------------------------ diff --git a/binaries/src/disembl/Tisean_3.0.1/test.f b/binaries/src/disembl/Tisean_3.0.1/test.f new file mode 100644 index 0000000..b6d433a --- /dev/null +++ b/binaries/src/disembl/Tisean_3.0.1/test.f @@ -0,0 +1,6 @@ + integer argv + argv=6 +c call getarg(1,argv) + write(99,*) argv + call FLUSH(99) + end diff --git a/binaries/src/disembl/disembl b/binaries/src/disembl/disembl index 7a11f1adf7bf148b6d251b5af0de8a988435e877..1234099735c2d8f1c7911f5ff9d2b672f0496124 100644 GIT binary patch delta 265 zcmX^9U;Frf?F|Q*m{gc1A7YAQyxpwG+^)#X2*gZ43}UkYF)I+W0Wmuea{w{tc130` zljo8a2IdAP3K~JFDGDBmB?=~bhI&T2CKj3u(;Z%Mi4LT+I1Z<64|>gYj~D3O?M6Sj P)R-7=Z;$-VmB#`A4*5g~ delta 265 zcmX^9U;Frf?F|Q*n65HTKExEq*ww7a+^)#X2*gZ43}UkYF)I+W0Wmuea{w{tc130` zljoA=24+TP3K~JFDGDBmB?=~bhI&T2h9;T}(;Z%Mi4v4HG&C|n*KJ}1*G-AEI1Z<6 b4|>gYj~D3O?M6Sj)R-8%wnzTv%3}clXA4A` -- 1.7.10.2