--- /dev/null
+ 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.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ 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.
+
+ <signature of Ty Coon>, 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.
--- /dev/null
+To install type
+
+./configue
+make
+make install
+
+and observe the warnings :-)
+
--- /dev/null
+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 )
--- /dev/null
+_______________________________________________________________________________
+
+ _/_/_/_/_/ _/ _/_/_/ _/_/_/_/ _/_/ _/ _/
+ _/ _/ _/ _/ _/ _/ _/ _/ _/
+ _/ _/ _/ _/ _/ _/ _/_/ _/
+ _/ _/ _/_/_/ _/_/_/_/ _/_/_/_/ _/ _/ _/
+ _/ _/ _/ _/ _/ _/ _/ _/_/
+ _/ _/ _/ _/ _/ _/ _/ _/ _/
+ _/ _/ _/_/_/ _/_/_/_/ _/ _/ _/ _/
+
+ 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.
--- /dev/null
+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
--- /dev/null
+#! /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}
--- /dev/null
+#! /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 <<EOF
+#line 611 "configure"
+#include "confdefs.h"
+
+int main() {
+main()
+; return 0; }
+EOF
+if { (eval echo configure:618: \"$ac_link\") 1>&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 <<EOF
+#define $ac_tr_lib 1
+EOF
+
+ LIBS="-lm $LIBS"
+
+else
+ echo "$ac_t""no" 1>&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 <<EOF
+#line 662 "configure"
+#include "confdefs.h"
+#include <assert.h>
+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 <<EOF
+#line 679 "configure"
+#include "confdefs.h"
+#include <assert.h>
+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 <<EOF
+#line 696 "configure"
+#include "confdefs.h"
+#include <assert.h>
+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 <<EOF
+#line 732 "configure"
+#include "confdefs.h"
+#include <stdlib.h>
+#include <stdarg.h>
+#include <string.h>
+#include <float.h>
+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
+#line 757 "configure"
+#include "confdefs.h"
+#include <string.h>
+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
+#line 775 "configure"
+#include "confdefs.h"
+#include <stdlib.h>
+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 <<EOF
+#line 796 "configure"
+#include "confdefs.h"
+#include <ctype.h>
+#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
+#line 839 "configure"
+#include "confdefs.h"
+#include <$ac_hdr>
+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 <<EOF
+#define $ac_tr_hdr 1
+EOF
+
+else
+ echo "$ac_t""no" 1>&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 <<EOF
+#line 877 "configure"
+#include "confdefs.h"
+
+int main() {
+
+/* Ultrix mips cc rejects this. */
+typedef int charset[2]; const charset x;
+/* SunOS 4.1.1 cc rejects this. */
+char const *const *ccp;
+char **p;
+/* NEC SVR4.0.2 mips cc rejects this. */
+struct point {int x, y;};
+static struct point const zero = {0,0};
+/* AIX XL C 1.02.0.0 rejects this.
+ It does not let you subtract one const X* pointer from another in an arm
+ of an if-expression whose if-part is not a constant expression */
+const char *g = "string";
+ccp = &g + (g ? g-g : 0);
+/* HPUX 7.0 cc rejects these. */
+++ccp;
+p = (char**) ccp;
+ccp = (char const *const *) p;
+{ /* SCO 3.2v4 cc rejects this. */
+ char *t;
+ char const *s = 0 ? (char *) 0 : (char const *) 0;
+
+ *t++ = 0;
+}
+{ /* Someone thinks the Sun supposedly-ANSI compiler will reject this. */
+ int x[] = {25, 17};
+ const int *foo = &x[0];
+ ++foo;
+}
+{ /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */
+ typedef const int *iptr;
+ iptr p = 0;
+ ++p;
+}
+{ /* AIX XL C 1.02.0.0 rejects this saying
+ "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */
+ struct s { int j; const int *ap[3]; };
+ struct s *b; b->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 <<EOF
+#line 956 "configure"
+#include "confdefs.h"
+#include <sys/types.h>
+#if STDC_HEADERS
+#include <stdlib.h>
+#include <stddef.h>
+#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 <<EOF
+#line 993 "configure"
+#include "confdefs.h"
+
+main()
+{
+ char c0 = 0x40, c1 = 0x80, c2 = 0x81;
+ exit(memcmp(&c0, &c2, 1) < 0 && memcmp(&c1, &c2, 1) < 0 ? 0 : 1);
+}
+
+EOF
+if { (eval echo configure:1003: \"$ac_link\") 1>&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 <<EOF
+set out "/dev/null"
+set term dumb
+plot '< (echo "1 1"; echo "2 2")'
+EOF
+ if $GP conftest.gnu 2>&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 <<EOF
+#! /bin/sh
+# Generated automatically by configure.
+# Run this file to recreate the current configuration.
+# This directory was configured as follows,
+# on host `(hostname || uname -n) 2>/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 <<EOF
+
+# Protect against being on the right side of a sed subst in config.status.
+sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g;
+ s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > 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 <<EOF
+
+CONFIG_FILES=\${CONFIG_FILES-"Makefile source_f/Makefile source_f/slatec/Makefile source_f/randomize/Makefile source_c/Makefile source_c/routines/Makefile"}
+EOF
+cat >> $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 <<EOF
+
+EOF
+cat >> $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
+
--- /dev/null
+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 <<EOF
+set out "/dev/null"
+set term dumb
+plot '< (echo "1 1"; echo "2 2")'
+EOF
+ if $GP conftest.gnu 2>&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)
--- /dev/null
+# -*- 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
--- /dev/null
+<html>
+<head><title>Nonlinear Time Series Routines</title></head>
+<FRAMESET cols="15%,*" framespacing=1 frameborder=1 border=1>
+ <FRAME NAME="quick" SRC="docs/quick.html">
+ <FRAME NAME="main" SRC="docs/indexf.html">
+</FRAMESET>
+</html>
\ No newline at end of file
--- /dev/null
+#! /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
--- /dev/null
+_______________________________________________________________________________
+
+ _/_/_/_/_/ _/ _/_/_/ _/_/_/_/ _/_/ _/ _/
+ _/ _/ _/ _/ _/ _/ _/ _/ _/
+ _/ _/ _/ _/ _/ _/ _/_/ _/
+ _/ _/ _/_/_/ _/_/_/_/ _/_/_/_/ _/ _/ _/
+ _/ _/ _/ _/ _/ _/ _/ _/_/
+ _/ _/ _/ _/ _/ _/ _/ _/ _/
+ _/ _/ _/_/_/ _/_/_/_/ _/ _/ _/ _/
+
+ Nonlinear time series pproject
+ Copyright (C) Rainer Hegger & Thomas Schreiber (1998-2007)
+_______________________________________________________________________________
+
--- /dev/null
+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
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include <math.h>
+#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<dim;i++) {
+ variance(series[i],length,&my_average[i],&var);
+ for (j=0;j<length;j++)
+ series[i][j] -= my_average[i];
+ }
+}
+
+double** build_matrix(double **mat)
+{
+ long n,i1,j1,i2,j2,hi,hj;
+ double norm;
+
+ norm=1./((double)length-(double)poles);
+
+ for (i1=0;i1<dim;i1++)
+ for (i2=0;i2<poles;i2++) {
+ hi=i1*poles+i2;
+ for (j1=0;j1<dim;j1++)
+ for (j2=0;j2<poles;j2++) {
+ hj=j1*poles+j2;
+ mat[hi][hj]=0.0;
+ for (n=poles-1;n<length-1;n++)
+ mat[hi][hj] += series[i1][n-i2]*series[j1][n-j2];
+ mat[hi][hj] *= norm;
+ }
+ }
+
+ return invert_matrix(mat,(unsigned int)(dim*poles));
+}
+
+void build_vector(double *vec,long comp)
+{
+ long i1,i2,hi,n;
+ double norm;
+
+ norm=1./((double)length-(double)poles);
+
+ for (i1=0;i1<poles*dim;i1++)
+ vec[i1]=0.0;
+
+ for (i1=0;i1<dim;i1++)
+ for (i2=0;i2<poles;i2++) {
+ hi=i1*poles+i2;
+ for (n=poles-1;n<length-1;n++)
+ vec[hi] += series[comp][n+1]*series[i1][n-i2];
+ vec[hi] *= norm;
+ }
+}
+
+double* multiply_matrix_vector(double **mat,double *vec)
+{
+ long i,j;
+ double *new_vec;
+
+ check_alloc(new_vec=(double*)malloc(sizeof(double)*poles*dim));
+
+ for (i=0;i<poles*dim;i++) {
+ new_vec[i]=0.0;
+ for (j=0;j<poles*dim;j++)
+ new_vec[i] += mat[i][j]*vec[j];
+ }
+ return new_vec;
+}
+
+double* make_residuals(double **diff,double **coeff)
+{
+ long n,d,i,j;
+ double *resi;
+
+ check_alloc(resi=(double*)malloc(sizeof(double)*dim));
+ for (i=0;i<dim;i++)
+ resi[i]=0.0;
+
+ for (n=poles-1;n<length-1;n++) {
+ for (d=0;d<dim;d++) {
+ diff[d][n+1]=series[d][n+1];
+ for (i=0;i<dim;i++)
+ for (j=0;j<poles;j++)
+ diff[d][n+1] -= coeff[d][i*poles+j]*series[i][n-j];
+ resi[d] += sqr(diff[d][n+1]);
+ }
+ }
+ for (i=0;i<dim;i++)
+ resi[i]=sqrt(resi[i]/((double)length-(double)poles));
+
+ return resi;
+}
+
+void iterate_model(double **coeff,double *sigma,FILE *file)
+{
+ long i,j,i1,i2,n,d;
+ double **iterate,*swap;
+
+ check_alloc(iterate=(double**)malloc(sizeof(double*)*(poles+1)));
+ for (i=0;i<=poles;i++)
+ check_alloc(iterate[i]=(double*)malloc(sizeof(double)*dim));
+ rnd_init(0x44325);
+ for (i=0;i<1000;i++)
+ gaussian(1.0);
+ for (i=0;i<dim;i++)
+ for (j=0;j<poles;j++)
+ iterate[j][i]=gaussian(sigma[i]);
+
+ for (n=0;n<ilength;n++) {
+ for (d=0;d<dim;d++) {
+ iterate[poles][d]=gaussian(sigma[d]);
+ for (i1=0;i1<dim;i1++)
+ for (i2=0;i2<poles;i2++)
+ iterate[poles][d] += coeff[d][i1*poles+i2]*iterate[poles-1-i2][i1];
+ }
+ if (file != NULL) {
+ for (d=0;d<dim;d++)
+ fprintf(file,"%e ",iterate[poles][d]);
+ fprintf(file,"\n");
+ }
+ else {
+ for (d=0;d<dim;d++)
+ printf("%e ",iterate[poles][d]);
+ printf("\n");
+ }
+
+ swap=iterate[0];
+ for (i=0;i<poles;i++)
+ iterate[i]=iterate[i+1];
+ iterate[poles]=swap;
+ }
+
+ for (i=0;i<=poles;i++)
+ free(iterate[i]);
+ free(iterate);
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0;
+ double *pm;
+ long i,j;
+ FILE *file;
+ double **mat,**inverse,*vec,**coeff,**diff,avpm;
+
+ 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)+4,(size_t)1));
+ strcpy(outfile,infile);
+ strcat(outfile,".ar");
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)9,(size_t)1));
+ strcpy(outfile,"stdin.ar");
+ }
+ }
+ if (!stdo)
+ test_outfile(outfile);
+
+ 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);
+
+ check_alloc(my_average=(double*)malloc(sizeof(double)*dim));
+ set_averages_to_zero();
+
+ if (poles >= 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<poles*dim;i++)
+ check_alloc(mat[i]=(double*)malloc(sizeof(double)*poles*dim));
+
+ check_alloc(coeff=(double**)malloc(sizeof(double*)*dim));
+ inverse=build_matrix(mat);
+ for (i=0;i<dim;i++) {
+ build_vector(vec,i);
+ coeff[i]=multiply_matrix_vector(inverse,vec);
+ }
+
+ check_alloc(diff=(double**)malloc(sizeof(double*)*dim));
+ for (i=0;i<dim;i++)
+ check_alloc(diff[i]=(double*)malloc(sizeof(double)*length));
+
+ pm=make_residuals(diff,coeff);
+
+ if (stdo) {
+ avpm=pm[0]*pm[0];
+ for (i=1;i<dim;i++)
+ avpm += pm[i]*pm[i];
+ avpm=sqrt(avpm/dim);
+ printf("#average forcast error= %e\n",avpm);
+ printf("#individual forecast errors: ");
+ for (i=0;i<dim;i++)
+ printf("%e ",pm[i]);
+ printf("\n");
+ for (i=0;i<dim*poles;i++) {
+ printf("# ");
+ for (j=0;j<dim;j++)
+ printf("%e ",coeff[j][i]);
+ printf("\n");
+ }
+ if (!run_model || (verbosity&VER_USR1)) {
+ for (i=poles;i<length;i++) {
+ if (run_model)
+ printf("#");
+ for (j=0;j<dim;j++)
+ if (verbosity&VER_USR2)
+ printf("%e %e ",series[j][i]+my_average[j],diff[j][i]);
+ else
+ printf("%e ",diff[j][i]);
+ printf("\n");
+ }
+ }
+ if (run_model && (ilength > 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<dim;i++)
+ avpm += pm[i]*pm[i];
+ avpm=sqrt(avpm/dim);
+ fprintf(file,"#average forcast error= %e\n",avpm);
+ fprintf(file,"#individual forecast errors: ");
+ for (i=0;i<dim;i++)
+ fprintf(file,"%e ",pm[i]);
+ fprintf(file,"\n");
+ for (i=0;i<dim*poles;i++) {
+ fprintf(file,"# ");
+ for (j=0;j<dim;j++)
+ fprintf(file,"%e ",coeff[j][i]);
+ fprintf(file,"\n");
+ }
+ if (!run_model || (verbosity&VER_USR1)) {
+ for (i=poles;i<length;i++) {
+ if (run_model)
+ fprintf(file,"#");
+ for (j=0;j<dim;j++)
+ if (verbosity&VER_USR2)
+ fprintf(file,"%e %e ",series[j][i]+my_average[j],diff[j][i]);
+ else
+ fprintf(file,"%e ",diff[j][i]);
+ fprintf(file,"\n");
+ }
+ }
+ if (run_model && (ilength > 0))
+ iterate_model(coeff,pm,file);
+ fclose(file);
+ }
+
+ if (outfile != NULL)
+ free(outfile);
+ if (infile != NULL)
+ free(infile);
+ free(vec);
+ for (i=0;i<poles*dim;i++) {
+ free(mat[i]);
+ free(inverse[i]);
+ }
+ free(mat);
+ free(inverse);
+ for (i=0;i<dim;i++) {
+ free(coeff[i]);
+ free(diff[i]);
+ }
+ free(coeff);
+ free(diff);
+ free(pm);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 6, 2006 */
+/*Changes:
+ Feb 4, 2006: First version
+ Feb 6, 2006: Find and remove bugs (1)
+ Feb 11, 2006: Add rand_arb_dist to iterate_***_model
+ */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include <math.h>
+#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<dim;d++)
+ series[d][i]=series[d][i]-series[d][i-1];
+}
+
+unsigned int** make_ar_index(void)
+{
+ unsigned int** ar_index;
+ unsigned long i;
+
+ check_alloc(ar_index=(unsigned int**)malloc(sizeof(unsigned int*)*2));
+ for (i=0;i<2;i++)
+ check_alloc(ar_index[i]=(unsigned int*)
+ malloc(sizeof(unsigned int)*ardim));
+ for (i=0;i<ardim;i++) {
+ ar_index[0][i]=i/poles;
+ ar_index[1][i]=i%poles;
+ }
+ return ar_index;
+}
+
+unsigned int** make_arima_index(unsigned int ars,unsigned int mas)
+{
+ unsigned int** arima_index;
+ unsigned int armad;
+ unsigned long i,i0;
+
+ armad=(ars+mas)*dim;
+ check_alloc(arima_index=(unsigned int**)malloc(sizeof(unsigned int*)*2));
+ for (i=0;i<2;i++)
+ check_alloc(arima_index[i]=(unsigned int*)
+ malloc(sizeof(unsigned int)*armad));
+ for (i=0;i<ars*dim;i++) {
+ arima_index[0][i]=i/ars;
+ arima_index[1][i]=i%ars;
+ }
+ i0=ars*dim;
+ for (i=0;i<mas*dim;i++) {
+ arima_index[0][i+i0]=dim+i/mas;
+ arima_index[1][i+i0]=i%mas;
+ }
+
+ return arima_index;
+}
+
+void set_averages_to_zero(void)
+{
+ double var;
+ long i,j;
+
+ for (i=0;i<dim;i++) {
+ variance(series[i],length,&my_average[i],&var);
+ for (j=0;j<length;j++)
+ series[i][j] -= my_average[i];
+ }
+}
+
+double** build_matrix(double **mat,unsigned int size)
+{
+ long n,i,j,is,id,js,jd;
+ double norm;
+
+ norm=1./((double)length-1.0-(double)poles-(double)offset);
+
+ for (i=0;i<size;i++) {
+ id=aindex[0][i];
+ is=aindex[1][i];
+ for (j=i;j<size;j++) {
+ jd=aindex[0][j];
+ js=aindex[1][j];
+ mat[i][j]=0.0;
+ for (n=offset+poles-1;n<length-1;n++)
+ mat[i][j] += series[id][n-is]*series[jd][n-js];
+ mat[i][j] *= norm;
+ mat[j][i]=mat[i][j];
+ }
+ }
+
+ return invert_matrix(mat,size);
+}
+
+void build_vector(double *vec,unsigned int size,long comp)
+{
+ long i,is,id,n;
+ double norm;
+
+ norm=1./((double)length-1.0-(double)poles-(double)offset);
+
+ for (i=0;i<size;i++) {
+ id=aindex[0][i];
+ is=aindex[1][i];
+ vec[i]=0.0;
+ for (n=offset+poles-1;n<length-1;n++)
+ vec[i] += series[comp][n+1]*series[id][n-is];
+ vec[i] *= norm;
+ }
+}
+
+double* multiply_matrix_vector(double **mat,double *vec,unsigned int size)
+{
+ long i,j;
+ double *new_vec;
+
+ check_alloc(new_vec=(double*)malloc(sizeof(double)*size));
+
+ for (i=0;i<size;i++) {
+ new_vec[i]=0.0;
+ for (j=0;j<size;j++)
+ new_vec[i] += mat[i][j]*vec[j];
+ }
+
+ return new_vec;
+}
+
+double* make_residuals(double **diff,double **coeff,unsigned int size)
+{
+ long n,n1,d,i,is,id;
+ double *resi;
+
+ check_alloc(resi=(double*)malloc(sizeof(double)*dim));
+ for (i=0;i<dim;i++)
+ resi[i]=0.0;
+
+ for (n=poles-1;n<length-1;n++) {
+ n1=n+1;
+ for (d=0;d<dim;d++) {
+ diff[d][n1]=series[d][n1];
+ for (i=0;i<size;i++) {
+ id=aindex[0][i];
+ is=aindex[1][i];
+ diff[d][n1] -= coeff[d][i]*series[id][n-is];
+ }
+ resi[d] += sqr(diff[d][n1]);
+ }
+ }
+
+ for (i=0;i<dim;i++)
+ resi[i]=sqrt(resi[i]/((double)length-(double)poles));
+
+ return resi;
+}
+
+void iterate_model(double **coeff,double *sigma,double **diff,FILE *file)
+{
+ long i,j,i1,i2,n,d;
+ double **iterate,*swap,**myrand;
+
+ check_alloc(iterate=(double**)malloc(sizeof(double*)*(poles+1)));
+ for (i=0;i<=poles;i++)
+ check_alloc(iterate[i]=(double*)malloc(sizeof(double)*dim));
+
+ check_alloc(myrand=(double**)malloc(sizeof(double*)*dim));
+ for (i=0;i<dim;i++)
+ myrand[i]=rand_arb_dist(diff[i],length,ilength+poles,100,0x44325);
+
+ rnd_init(0x44325);
+ for (i=0;i<1000;i++)
+ rnd_long();
+ for (i=0;i<dim;i++)
+ for (j=0;j<poles;j++)
+ iterate[j][i]=myrand[i][j];
+
+ for (n=0;n<ilength;n++) {
+ for (d=0;d<dim;d++) {
+ iterate[poles][d]=myrand[d][n+poles];
+ for (i1=0;i1<dim;i1++)
+ for (i2=0;i2<poles;i2++)
+ iterate[poles][d] += coeff[d][i1*poles+i2]*iterate[poles-1-i2][i1];
+ }
+ if (file != NULL) {
+ for (d=0;d<dim;d++)
+ fprintf(file,"%e ",iterate[poles][d]);
+ fprintf(file,"\n");
+ }
+ else {
+ for (d=0;d<dim;d++)
+ printf("%e ",iterate[poles][d]);
+ printf("\n");
+ }
+
+ swap=iterate[0];
+ for (i=0;i<poles;i++)
+ iterate[i]=iterate[i+1];
+ iterate[poles]=swap;
+ }
+
+ for (i=0;i<=poles;i++)
+ free(iterate[i]);
+ free(iterate);
+
+ for (i=0;i<dim;i++)
+ free(myrand[i]);
+ free(myrand);
+}
+
+void iterate_arima_model(double **coeff,double *sigma,double **diff,FILE *file)
+{
+ double **iterate,*swap,**myrand;
+ unsigned long i,j,n,is,id;
+
+ check_alloc(iterate=(double**)malloc(sizeof(double*)*(poles+1)));
+ for (i=0;i<=poles;i++)
+ check_alloc(iterate[i]=(double*)malloc(sizeof(double)*2*dim));
+
+ check_alloc(myrand=(double**)malloc(sizeof(double*)*dim));
+ for (i=0;i<dim;i++)
+ myrand[i]=rand_arb_dist(diff[i],length,ilength+poles,100,0x44325);
+
+ rnd_init(0x44325);
+ for (i=0;i<1000;i++)
+ rnd_long();
+ for (i=0;i<dim;i++)
+ for (j=0;j<poles;j++)
+ iterate[j][i]=iterate[j][dim+i]=myrand[i][j];
+
+ for (n=0;n<ilength;n++) {
+ for (i=0;i<dim;i++)
+ iterate[poles][i]=iterate[poles][i+dim]=myrand[i][n+poles];
+
+ for (j=0;j<dim;j++) {
+ for (i=0;i<armadim;i++) {
+ id=aindex[0][i];
+ is=aindex[1][i];
+ iterate[poles][j] += coeff[j][i]*iterate[poles-1-is][id];
+ }
+ }
+
+ if (file != NULL) {
+ for (i=0;i<dim;i++)
+ fprintf(file,"%e ",iterate[poles][i]);
+ fprintf(file,"\n");
+ }
+ else {
+ for (i=0;i<dim;i++)
+ printf("%e ",iterate[poles][i]);
+ printf("\n");
+ }
+
+ swap=iterate[0];
+ for (i=0;i<poles;i++)
+ iterate[i]=iterate[i+1];
+ iterate[poles]=swap;
+ }
+
+ for (i=0;i<=poles;i++)
+ free(iterate[i]);
+ free(iterate);
+ for (i=0;i<dim;i++)
+ free(myrand[i]);
+ free(myrand);
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0;
+ double *pm;
+ long i,j,iter,hj,realiter=0;
+ unsigned int size,is,id;
+ FILE *file;
+ double **mat,**inverse,*vec,**coeff,**diff,**hseries;
+ double **oldcoeff,*diffcoeff=NULL;
+ double hdiff,**xdiff=NULL,avpm;
+ double loglikelihood,aic,alldiff;
+
+ 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,".ari");
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1));
+ strcpy(outfile,"stdin.ari");
+ }
+ }
+ if (!stdo)
+ test_outfile(outfile);
+
+ 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);
+
+ check_alloc(my_average=(double*)malloc(sizeof(double)*dim));
+
+ for (i=0;i<ipoles;i++)
+ make_difference();
+
+ for (i=0;i<dim;i++)
+ series[i] += ipoles;
+ length -= ipoles;
+
+ set_averages_to_zero();
+
+ if (poles >= 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<ardim;i++)
+ check_alloc(mat[i]=(double*)malloc(sizeof(double)*ardim));
+
+ check_alloc(coeff=(double**)malloc(sizeof(double*)*dim));
+ inverse=build_matrix(mat,ardim);
+ for (i=0;i<dim;i++) {
+ build_vector(vec,ardim,i);
+ coeff[i]=multiply_matrix_vector(inverse,vec,ardim);
+ }
+
+ check_alloc(diff=(double**)malloc(sizeof(double*)*dim));
+ for (i=0;i<dim;i++)
+ check_alloc(diff[i]=(double*)malloc(sizeof(double)*length));
+
+ pm=make_residuals(diff,coeff,ardim);
+
+ free(vec);
+ for (i=0;i<ardim;i++) {
+ free(mat[i]);
+ free(inverse[i]);
+ }
+ free(mat);
+ free(inverse);
+ size=ardim;
+
+ if (arimaset) {
+ offset=poles;
+ for (i=0;i<2;i++)
+ free(aindex[i]);
+ free(aindex);
+
+ for (i=0;i<dim;i++)
+ free(coeff[i]);
+ free(coeff);
+ check_alloc(xdiff=(double**)malloc(sizeof(double*)*ITER));
+ for (i=0;i<ITER;i++)
+ check_alloc(xdiff[i]=(double*)malloc(sizeof(double)*dim));
+
+ armadim=(arpoles+mapoles)*dim;
+ aindex=make_arima_index(arpoles,mapoles);
+ size=armadim;
+
+ check_alloc(hseries=(double**)malloc(sizeof(double*)*2*dim));
+ for (i=0;i<dim;i++) {
+ check_alloc(hseries[i]=(double*)malloc(sizeof(double)*length));
+ check_alloc(hseries[i+dim]=(double*)malloc(sizeof(double)*length));
+ for (j=0;j<length;j++) {
+ hseries[i][j]=series[i][j];
+ hseries[i+dim][j]=diff[i][j];
+ }
+ }
+
+ for (i=0;i<dim;i++)
+ free(series[i]-ipoles);
+ free(series);
+
+ series=hseries;
+
+ check_alloc(oldcoeff=(double**)malloc(sizeof(double*)*dim));
+ for (i=0;i<dim;i++) {
+ check_alloc(oldcoeff[i]=(double*)malloc(sizeof(double)*armadim));
+ for (j=0;j<armadim;j++)
+ oldcoeff[i][j]=0.0;
+ }
+ check_alloc(diffcoeff=(double*)malloc(sizeof(double)*ITER));
+
+ for (iter=1;iter<=ITER;iter++) {
+ check_alloc(vec=(double*)malloc(sizeof(double)*armadim));
+ check_alloc(mat=(double**)malloc(sizeof(double*)*armadim));
+ for (i=0;i<armadim;i++)
+ check_alloc(mat[i]=(double*)malloc(sizeof(double)*armadim));
+
+ check_alloc(coeff=(double**)malloc(sizeof(double*)*dim));
+
+ poles=(arpoles > mapoles)? arpoles:mapoles;
+
+ offset += poles;
+ inverse=build_matrix(mat,armadim);
+
+ for (i=0;i<dim;i++) {
+ build_vector(vec,armadim,i);
+ coeff[i]=multiply_matrix_vector(inverse,vec,armadim);
+ }
+
+ pm=make_residuals(diff,coeff,armadim);
+
+ for (j=0;j<dim;j++) {
+ hdiff=0.0;
+ hj=j+dim;
+ for (i=offset;i<length;i++)
+ hdiff += sqr(series[hj][i]-diff[j][i]);
+ for (i=0;i<length;i++) {
+ series[hj][i]=diff[j][i];
+ }
+ xdiff[iter-1][j]=sqrt(hdiff/(double)(length-offset));
+ }
+
+ free(vec);
+ for (i=0;i<armadim;i++) {
+ free(mat[i]);
+ free(inverse[i]);
+ }
+ free(mat);
+ free(inverse);
+
+ diffcoeff[iter-1]=0.0;
+ for (i=0;i<dim;i++)
+ for (j=0;j<dim;j++) {
+ diffcoeff[iter-1] += sqr(coeff[i][j]-oldcoeff[i][j]);
+ oldcoeff[i][j]=coeff[i][j];
+ }
+ diffcoeff[iter-1]=sqrt(diffcoeff[iter-1]/(double)armadim);
+ alldiff=xdiff[iter-1][0];
+ for (i=1;i<dim;i++)
+ if (xdiff[iter-1][i] > alldiff)
+ alldiff=xdiff[iter-1][i];
+ realiter=iter;
+ if (alldiff < convergence)
+ iter=ITER;
+
+ if (iter < ITER) {
+ for (i=0;i<dim;i++)
+ free(coeff[i]);
+ free(coeff);
+ }
+ }
+ }
+
+ if (stdo) {
+ if (arimaset) {
+ printf("#convergence of residuals in arima fit\n");
+ for (i=0;i<realiter;i++) {
+ printf("#iteration %ld ",i+1);
+ for (j=0;j<dim;j++)
+ printf("%e ",xdiff[i][j]);
+ printf("%e",diffcoeff[i]);
+ printf("\n");
+ }
+ }
+ avpm=pm[0]*pm[0];
+ loglikelihood= -log(pm[0]);
+ for (i=1;i<dim;i++) {
+ avpm += pm[i]*pm[i];
+ loglikelihood -= log(pm[i]);
+ }
+ loglikelihood *= ((double)length);
+ loglikelihood += -((double)length)*
+ ((1.0+log(2.*M_PI))*dim)/2.0;
+ avpm=sqrt(avpm/dim);
+ printf("#average forcast error= %e\n",avpm);
+ printf("#individual forecast errors: ");
+ for (i=0;i<dim;i++)
+ printf("%e ",pm[i]);
+ printf("\n");
+ if (arimaset)
+ aic=2.0*(arpoles+mapoles)-2.0*loglikelihood;
+ else
+ aic=2.0*poles-2.0*loglikelihood;
+ printf("#Log-Likelihood= %e\t AIC= %e\n",loglikelihood,aic);
+ for (i=0;i<size;i++) {
+ id=aindex[0][i];
+ is=aindex[1][i];
+ if (id < dim)
+ printf("#x_%u(n-%u) ",id+1,is);
+ else
+ printf("#e_%u(n-%u) ",id+1-dim,is);
+ for (j=0;j<dim;j++)
+ printf("%e ",coeff[j][i]);
+ printf("\n");
+ }
+ if (!run_model || (verbosity&VER_USR1)) {
+ for (i=poles;i<length;i++) {
+ if (run_model)
+ printf("#");
+ for (j=0;j<dim;j++)
+ if (verbosity&VER_USR2)
+ printf("%e %e ",series[j][i]+my_average[j],diff[j][i]);
+ else
+ printf("%e ",diff[j][i]);
+ printf("\n");
+ }
+ }
+ if (run_model && (ilength > 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<realiter;i++) {
+ fprintf(file,"#iteration %ld ",i+1);
+ for (j=0;j<dim;j++)
+ fprintf(file,"%e ",xdiff[i][j]);
+ fprintf(file,"%e",diffcoeff[i]);
+ fprintf(file,"\n");
+ }
+ }
+ avpm=pm[0]*pm[0];
+ loglikelihood= -log(pm[0]);
+ for (i=1;i<dim;i++) {
+ avpm += pm[i]*pm[i];
+ loglikelihood -= log(pm[i]);
+ }
+ loglikelihood *= ((double)length);
+ loglikelihood += -((double)length)*
+ ((1.0+log(2.*M_PI))*dim)/2.0;
+ avpm=sqrt(avpm/dim);
+ fprintf(file,"#average forcast error= %e\n",avpm);
+ fprintf(file,"#individual forecast errors: ");
+ for (i=0;i<dim;i++)
+ fprintf(file,"%e ",pm[i]);
+ fprintf(file,"\n");
+ if (arimaset)
+ aic=2.0*(arpoles+mapoles)-2.0*loglikelihood;
+ else
+ aic=2.0*poles-2.0*loglikelihood;
+ fprintf(file,"#Log-Likelihood= %e\t AIC= %e\n",loglikelihood,aic);
+ for (i=0;i<size;i++) {
+ id=aindex[0][i];
+ is=aindex[1][i];
+ if (id < dim)
+ fprintf(file,"#x_%u(n-%u) ",id+1,is);
+ else
+ fprintf(file,"#e_%u(n-%u) ",id+1-dim,is);
+ for (j=0;j<dim;j++)
+ fprintf(file,"%e ",coeff[j][i]);
+ fprintf(file,"\n");
+ }
+ if (!run_model || (verbosity&VER_USR1)) {
+ for (i=poles;i<length;i++) {
+ if (run_model)
+ fprintf(file,"#");
+ for (j=0;j<dim;j++)
+ if (verbosity&VER_USR2)
+ fprintf(file,"%e %e ",series[j][i]+my_average[j],diff[j][i]);
+ else
+ fprintf(file,"%e ",diff[j][i]);
+ fprintf(file,"\n");
+ }
+ }
+ if (run_model && (ilength > 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<dim;i++) {
+ free(coeff[i]);
+ free(diff[i]);
+ free(series[i]);
+ if (arimaset)
+ free(series[i+dim]);
+ }
+ free(coeff);
+ free(diff);
+ free(series);
+
+ free(pm);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <limits.h>
+#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<howmany-aver;k++) {
+ avy=aveps=0.0;
+ for (j= -aver;j<=aver;j++) {
+ avy += y[k+j];
+ aveps += eps[k+j];
+ }
+ if (!stout)
+ fprintf(fout,"%e %e\n",aveps/norm,avy/norm);
+ else
+ fprintf(stdout,"%e %e\n",aveps/norm,avy/norm);
+ }
+ if (!stout)
+ fprintf(fout,"\n");
+ else
+ fprintf(stdout,"\n");
+ }
+ }
+ }
+ }
+ }
+
+ if (outfile != NULL)
+ free(outfile);
+ if (infile != NULL)
+ free(infile);
+ free(eps);
+ free(y);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 22, 2006 */
+/* Changes:
+ 02/22/06: Remove this strange else in start_box that
+ did not compile anyways
+*/
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <string.h>
+#include <limits.h>
+#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;i<maxembed*dimension;i++)
+ element->hist[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<epsi;i++) {
+ found[i]=0;
+ act[i]=NULL;
+ }
+
+ for (i=0;i<n;i++) {
+ which=(int)(series[comp][first[i]+d1]*epsinv);
+ hf= ++found[which];
+ check_alloc(act[which]=
+ realloc((unsigned int*)act[which],hf*sizeof(unsigned int)));
+ act[which][hf-1]=first[i];
+ }
+
+ for (i=0;i<epsi;i++)
+ if (found[i]) {
+ p=(double)(found[i])/(norm);
+ if (Q == 1.0)
+ histo[wd] -= p*log(p);
+ else
+ histo[wd] += pow(p,Q);
+ }
+
+ if (wd<(maxembed*dimension-1))
+ for (i=0;i<epsi;i++)
+ if (found[i])
+ next_dim(wd+1,found[i],act[i]);
+
+ for (i=0;i<epsi;i++)
+ if (found[i])
+ free(act[i]);
+
+ free(act);
+ free(found);
+}
+
+void start_box(void)
+{
+ int i,which;
+ double epsinv,norm,p;
+ unsigned int **act;
+ int *found,hf;
+ void next_dim();
+
+ 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<epsi;i++) {
+ found[i]=0;
+ act[i]=NULL;
+ }
+
+ for (i=0;i<length;i++) {
+ which=(int)(series[0][i]*epsinv);
+ hf= ++found[which];
+ check_alloc(act[which]=
+ realloc((unsigned int*)act[which],hf*sizeof(unsigned int)));
+ act[which][hf-1]=i;
+ }
+
+ for (i=0;i<epsi;i++)
+ if (found[i]) {
+ p=(double)(found[i])/(norm);
+ if (Q == 1.0)
+ histo[0] -= p*log(p);
+ else
+ histo[0] += pow(p,Q);
+ }
+
+ if (1<dimension*maxembed) {
+ for (i=0;i<epsi;i++) {
+ if (found[i])
+ next_dim(1,found[i],act[i]);
+ }
+ }
+ /*
+ else {
+ if (1<maxembed)
+ for (i=0;i<epsi;i++) {
+ if (found[i])
+ next_dim(1,found[i],act[i]);
+ }
+ }
+ */
+
+ for (i=0;i<epsi;i++)
+ if (found[i])
+ free(act[i]);
+
+ free(act);
+ free(found);
+}
+
+int main(int argc,char **argv)
+{
+ int i,j,k,count,epsi_old=0,epsi_test;
+ void *root;
+ hliste *histo_el;
+ double *deps,heps;
+ double min,interval,maxinterval;
+ char *infile=NULL,stdi=0;
+ FILE *fHq;
+
+
+ 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));
+ sprintf(outfile,"%s.box",infile);
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1));
+ sprintf(outfile,"stdin.box");
+ }
+ }
+ test_outfile(outfile);
+
+ if (column == NULL)
+ series=(double**)get_multi_series(infile,&LENGTH,exclude,&dimension,"",
+ dimset,verbosity);
+ else
+ series=(double**)get_multi_series(infile,&LENGTH,exclude,&dimension,
+ column,dimset,verbosity);
+ maxinterval=0.0;
+ for (i=0;i<dimension;i++) {
+ rescale_data(series[i],LENGTH,&min,&interval);
+ if (interval > maxinterval)
+ maxinterval=interval;
+ }
+ if (epsminset)
+ EPSMIN /= maxinterval;
+ if (epsmaxset)
+ EPSMAX /= maxinterval;
+ for (i=0;i<dimension;i++) {
+ for (j=0;j<LENGTH;j++)
+ if (series[i][j] >= 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;i<maxembed*dimension;i++)
+ check_alloc(which_dims[i]=(unsigned int*)malloc(sizeof(int)*2));
+ for (i=0;i<maxembed;i++)
+ for (j=0;j<dimension;j++) {
+ which_dims[i*dimension+j][0]=j;
+ which_dims[i*dimension+j][1]=i;
+ }
+
+ histo_el=make_histo();
+ root=histo_el;
+
+ if (EPSCOUNT >1)
+ EPSFAKTOR=pow(EPSMAX/EPSMIN,1.0/(double)(EPSCOUNT-1));
+ else
+ EPSFAKTOR=1.0;
+
+ length=LENGTH-(maxembed-1)*DELAY;
+
+ heps=EPSMAX*EPSFAKTOR;
+
+ for (k=0;k<EPSCOUNT;k++) {
+ count++;
+ for (i=0;i<maxembed*dimension;i++)
+ histo[i]=0.0;
+ do {
+ heps /= EPSFAKTOR;
+ epsi_test=(int)(1./heps);
+ } while (epsi_test <= epsi_old);
+
+ epsi=epsi_test;
+ epsi_old=epsi;
+ deps[k]=heps;
+
+ start_box();
+ histo_el=root;
+ while (histo_el->ptr != NULL)
+ histo_el=histo_el->ptr;
+
+ for (i=0;i<maxembed*dimension;i++)
+ if (Q == 1.0)
+ histo_el->hist[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;i<maxembed*dimension;i++) {
+ fprintf(fHq,"#component = %d embedding = %d\n",which_dims[i][0]+1,
+ which_dims[i][1]+1);
+ histo_el=root;
+ for (j=0;j<=k;j++) {
+ if (i == 0)
+ fprintf(fHq,"%e %e %e\n",deps[j]*maxinterval,
+ histo_el->hist[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;
+}
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <limits.h>
+#include <string.h>
+#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<length;i++)
+ array[i] -= av;
+ }
+
+ if (!stout) {
+ fout=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ fprintf(fout,"# average=%e\n",av);
+ fprintf(fout,"# standard deviation=%e\n",var);
+ }
+ else {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Writing to stdout\n");
+ fprintf(stdout,"# average=%e\n",av);
+ fprintf(stdout,"# standard deviation=%e\n",var);
+ }
+ if (normalize)
+ var *= var;
+ else
+ var=1.0;
+
+ for (i=0;i<=tau;i++)
+ if (!stout) {
+ fprintf(fout,"%ld %e\n",i,corr(i)/var);
+ fflush(fout);
+ }
+ else {
+ fprintf(stdout,"%ld %e\n",i,corr(i)/var);
+ fflush(stdout);
+ }
+ if (!stout)
+ fclose(fout);
+
+ if (outfile != NULL)
+ free(outfile);
+ if (infile != NULL)
+ free(infile);
+ free(array);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 10, 2000 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <limits.h>
+#include <time.h>
+#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<hlength;i++)
+ rz[i]=(double)(rnd=rnd*rndf+1)/ULONG_MAX;
+
+ for (i=0;i<SCBOX;i++)
+ scbox[i]= -1;
+ for (i=0;i<hlength;i++) {
+ m=(int)(rz[i]*sceps)&scbox1;
+ scfound[i]=scbox[m];
+ scbox[m]=i;
+ }
+ for (i=0;i<SCBOX;i++) {
+ scnfound=0;
+ element=scbox[i];
+ while(element != -1) {
+ scnhelp[scnfound]=element;
+ schelp[scnfound++]=rz[element];
+ element=scfound[element];
+ }
+
+ for (j=0;j<scnfound-1;j++)
+ for (k=j+1;k<scnfound;k++)
+ if (schelp[k] < schelp[j]) {
+ swap=schelp[k];
+ schelp[k]=schelp[j];
+ schelp[j]=swap;
+ lswap=scnhelp[k];
+ scnhelp[k]=scnhelp[j];
+ scnhelp[j]=lswap;
+ }
+ for (j=0;j<scnfound;j++)
+ scr[allscr+j]=scnhelp[j];
+ allscr += scnfound;
+ }
+
+ free(rz);
+ free(scfound);
+ free(schelp);
+}
+
+void make_c2_dim(int n)
+{
+ char small;
+ long i,j,k,x,y,i1,i2,j1,element,n1,maxi,count,hi;
+ double *hs,max,dx;
+
+ check_alloc(hs=(double*)malloc(sizeof(double)*EMBED*DIM));
+ n1=scr[n];
+
+ count=0;
+ for (i1=0;i1<EMBED;i1++) {
+ i2=i1*DELAY;
+ for (j=0;j<DIM;j++)
+ hs[count++]=series[j][n1+i2];
+ }
+
+ x=(int)(hs[0]*epsinv)&imax;
+ y=(int)(hs[1]*epsinv)&imax;
+
+ for (i1=x-1;i1<=x+1;i1++) {
+ i2=i1&imax;
+ for (j1=y-1;j1<=y+1;j1++) {
+ element=box[i2][j1&imax];
+ while (element != -1) {
+ if (labs((long)(element-n1)) > MINDIST) {
+ count=0;
+ max=0.0;
+ maxi=howoften1;
+ small=0;
+ for (i=0;i<EMBED;i++) {
+ hi=i*DELAY;
+ for (j=0;j<DIM;j++) {
+ dx=fabs(hs[count]-series[j][element+hi]);
+ if (dx <= EPSMAX) {
+ if (dx > 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<DIM;i++)
+ rescale_data(series[i],length,&min,&interval);
+ maxinterval=1.0;
+ }
+ else {
+ maxinterval=0.0;
+ for (i=0;i<DIM;i++) {
+ min=interval=series[i][0];
+ for (j=1;j<length;j++) {
+ if (min > 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)<maxinterval) ? fabs(EPSMAX) : maxinterval;
+ EPSMIN=(fabs(EPSMIN)<EPSMAX) ? fabs(EPSMIN) : EPSMAX/2.;
+ EPSMAX1=EPSMAX;
+
+ howoften1=HOWOFTEN-1;
+ maxembed=DIM*EMBED-1;
+
+ check_alloc(outd1=(char*)calloc(strlen(FOUT)+4,(size_t)1));
+ check_alloc(outc1=(char*)calloc(strlen(FOUT)+4,(size_t)1));
+ check_alloc(outh1=(char*)calloc(strlen(FOUT)+4,(size_t)1));
+ check_alloc(outstat=(char*)calloc(strlen(FOUT)+6,(size_t)1));
+ strcpy(outd1,FOUT);
+ strcpy(outc1,FOUT);
+ strcpy(outh1,FOUT);
+ strcpy(outstat,FOUT);
+ strcat(outd1,".d2");
+ strcat(outc1,".c2");
+ strcat(outh1,".h2");
+ strcat(outstat,".stat");
+ test_outfile(outd1);
+ test_outfile(outc1);
+ test_outfile(outh1);
+ test_outfile(outstat);
+
+ check_alloc(list=(long*)malloc(length*sizeof(long)));
+ check_alloc(listc1=(long*)malloc(length*sizeof(long)));
+ if ((long)(length-(EMBED-1)*DELAY) <= 0) {
+ fprintf(stderr,"Embedding dimension and delay are too large.\n"
+ "The delay vector would be longer than the whole series."
+ " Exiting\n");
+ exit(VECTOR_TOO_LARGE_FOR_LENGTH);
+ }
+ check_alloc(scr=(long*)malloc(sizeof(long)*(length-(EMBED-1)*DELAY)));
+ check_alloc(oscr=(long*)malloc(sizeof(long)*(length-(EMBED-1)*DELAY)));
+ check_alloc(found=(double**)malloc(DIM*EMBED*sizeof(double*)));
+ for (i=0;i<EMBED*DIM;i++)
+ check_alloc(found[i]=(double*)malloc(HOWOFTEN*sizeof(double)));
+ check_alloc(norm=(double*)malloc(HOWOFTEN*sizeof(double)));
+ check_alloc(epsm=(double*)malloc(HOWOFTEN*sizeof(double)));
+
+ epsinv=1.0/EPSMAX;
+ epsfactor=pow(EPSMAX/EPSMIN,1.0/(double)howoften1);
+ lneps=log(EPSMAX);
+ lnfac=log(epsfactor);
+
+ epsm[0]=EPSMAX;
+ norm[0]=0.0;
+ for (i=1;i<HOWOFTEN;i++) {
+ norm[i]=0.0;
+ epsm[i]=epsm[i-1]/epsfactor;
+ }
+ imin=0;
+
+ scramble();
+ for (i=0;i<(length-(EMBED-1)*DELAY);i++)
+ oscr[scr[i]]=i;
+
+ for (i=0;i<DIM*EMBED;i++)
+ for (j=0;j<HOWOFTEN;j++)
+ found[i][j]=0.0;
+
+ nmax=length-DELAY*(EMBED-1);
+
+ for (i1=0;i1<NMAX;i1++) {
+ boxc1[i1]= -1;
+ for (j1=0;j1<NMAX;j1++)
+ box[i1][j1]= -1;
+ }
+ time(&lasttime);
+ lnorm=0;
+
+ for (n=1;n<nmax;n++) {
+ smaller=0;
+ sn=scr[n-1];
+ if (DIM > 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<NMAX;i1++) {
+ boxc1[i1]= -1;
+ for (j1=0;j1<NMAX;j1++)
+ box[i1][j1]= -1;
+ }
+ for (i1=0;i1<n;i1++) {
+ sn=scr[i1];
+ if (DIM > 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<length-(EMBED-1)*DELAY)?sn+MINDIST:
+ length-(EMBED-1)*DELAY-1;
+ for (i1=n1;i1<=n2;i1++)
+ if ((oscr[i1] < n))
+ lnorm--;
+ }
+
+ if (EMBED*DIM > 1)
+ make_c2_dim(n);
+ make_c2_1(n);
+ for (i=imin;i<HOWOFTEN;i++)
+ norm[i] += (double)(lnorm);
+ }
+
+ if (((time(&mytime)-lasttime) > 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<EMBED*DIM;i++) {
+ fprintf(fout,"#dim= %ld\n",i+1);
+ eps=EPSMAX1*epsfactor;
+ for (j=0;j<HOWOFTEN;j++) {
+ eps /= epsfactor;
+ if (norm[j] > 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<HOWOFTEN;j++) {
+ eps /= epsfactor;
+ if (found[0][j] > 0.0)
+ fprintf(fout,"%e %e\n",eps,-log(found[0][j]/norm[j]));
+ }
+ fprintf(fout,"\n\n");
+ for (i=1;i<DIM*EMBED;i++) {
+ fprintf(fout,"#dim= %ld\n",i+1);
+ eps=EPSMAX1*epsfactor;
+ for (j=0;j<HOWOFTEN;j++) {
+ eps /= epsfactor;
+ if ((found[i-1][j] > 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<DIM*EMBED;i++) {
+ fprintf(fout,"#dim= %ld\n",i+1);
+ eps=EPSMAX1;
+ for (j=1;j<HOWOFTEN;j++) {
+ eps /= epsfactor;
+ if ((found[i][j] > 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<EMBED*DIM;i++)
+ free(found[i]);
+ free(found);
+ for (i=0;i<DIM;i++)
+ free(series[i]);
+ free(series);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 (rewritten in C) Aug 22, 2004*/
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include <ctype.h>
+#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<num) {
+ while ((*format) != ',')
+ format++;
+ }
+ format++;
+ }
+
+ if (dimset && ((num+1) != indim)) {
+ fprintf(stderr,"Number of dimensions in -F is not equal to -M. Exiting!\n");
+ exit(DELAY_DIM_NOT_EQUAL_F_M);
+ }
+
+ for (i=0;i<=num;i++)
+ sum += formatlist[i];
+ if (embset && (sum != embdim)) {
+ fprintf(stderr,"The dimensions given in -m and -F are not equal!"
+ " Exiting\n");
+ exit(DELAY_DIM_NOT_EQUAL_F_m);
+ }
+ if (!dimset)
+ indim=num+1;
+ if (!embset)
+ embdim=sum;
+}
+
+void create_delay_list(void)
+{
+ unsigned int i=0,num=0;
+
+ while (multidelay[i]) {
+ if (!(isdigit(multidelay[i])) && !(multidelay[i] == ',')) {
+ fprintf(stderr,"Wrong format of -D parameter. Exiting!\n");
+ exit(DELAY_WRONG_FORMAT_D);
+ }
+ i++;
+ }
+
+ i=0;
+ while (multidelay[i]) {
+ if (multidelay[i++] == ',')
+ num++;
+ }
+
+ check_alloc(delaylist=(unsigned int*)malloc(sizeof(int)*(num+1)));
+ for (i=0;i<=num;i++) {
+ sscanf(multidelay,"%d",&delaylist[i]);
+ if (i<num) {
+ while ((*multidelay) != ',')
+ multidelay++;
+ }
+ multidelay++;
+ }
+
+ if ((num+1) != (embdim-indim)) {
+ fprintf(stderr,"Wrong number of delays. See man page. Exiting!\n");
+ exit(DELAY_WRONG_NUM_D);
+ }
+}
+
+int main(int argc,char **argv)
+{
+ char stin=0;
+ unsigned long i;
+ int j,k;
+ unsigned int alldim,maxemb,emb,rundel,delsum,runmdel;
+ unsigned int *inddelay;
+ 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,NULL,verbosity);
+ if (infile == NULL)
+ stin=1;
+
+ if (outfile == NULL) {
+ if (!stin) {
+ check_alloc(outfile=(char*)calloc(strlen(infile)+5,1));
+ strcpy(outfile,infile);
+ strcat(outfile,".del");
+ }
+ else {
+ check_alloc(outfile=(char*)calloc(10,1));
+ strcpy(outfile,"stdin.del");
+ }
+ }
+ if (!stdo)
+ test_outfile(outfile);
+
+ if (delayset && mdelayset) {
+ fprintf(stderr,"-d and -D can't be used simultaneously. Exiting!\n");
+ exit(DELAY_INCONS_d_D);
+ }
+
+ if (delay < 1) {
+ fprintf(stderr,"Delay has to be larger than 0. Exiting!\n");
+ exit(DELAY_SMALL_ZERO);
+ }
+
+ if (!formatset && (embdim%indim)) {
+ fprintf(stderr,"Inconsistent -m and -M. Please set -F\n");
+ exit(DELAY_INCONS_m_M);
+ }
+ if (formatset) {
+ create_format_list();
+ }
+ else {
+ check_alloc(formatlist=(unsigned int*)malloc(sizeof(int)*indim));
+ for (i=0;i<indim;i++) {
+ formatlist[i]=embdim/indim;
+ }
+ }
+
+ alldim=0;
+ for (i=0;i<indim;i++)
+ alldim += formatlist[i];
+
+ if (mdelayset) {
+ create_delay_list();
+ }
+
+ check_alloc(inddelay=(unsigned int*)malloc(sizeof(int)*alldim));
+
+ rundel=0;
+ if (!mdelayset) {
+ for (i=0;i<indim;i++) {
+ delsum=0;
+ inddelay[rundel++]=delsum;
+ for (j=1;j<formatlist[i];j++) {
+ delsum += delay;
+ inddelay[rundel++]=delsum;
+ }
+ }
+ }
+ else {
+ runmdel=0;
+ for (i=0;i<indim;i++) {
+ delsum=0;
+ inddelay[rundel++]=delsum;
+ for (j=1;j<formatlist[i];j++) {
+ delsum += delaylist[runmdel++];
+ inddelay[rundel++]=delsum;
+ }
+ }
+ }
+
+ maxemb=0;
+ for (i=0;i<alldim;i++)
+ maxemb=(maxemb<inddelay[i])?inddelay[i]:maxemb;
+
+ if (column == NULL) {
+ series=get_multi_series(infile,&length,exclude,&indim,"",dimset,verbosity);
+ }
+ else {
+ series=get_multi_series(infile,&length,exclude,&indim,column,dimset,
+ verbosity);
+ }
+
+ if (stdo) {
+ if (verbosity)
+ fprintf(stderr,"Writing to stdout\n");
+ for (i=maxemb;i<length;i++) {
+ rundel=0;
+ for (j=0;j<indim;j++) {
+ emb=formatlist[j];
+ for (k=0;k<emb;k++)
+ fprintf(stdout,"%e ",series[j][i-inddelay[rundel++]]);
+ }
+ fprintf(stdout,"\n");
+ }
+ }
+ else {
+ fout=fopen(outfile,"w");
+ if (verbosity)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ for (i=maxemb;i<length;i++) {
+ for (j=0;j<indim;j++) {
+ rundel=0;
+ emb=formatlist[j];
+ for (k=0;k<emb;k++)
+ fprintf(fout,"%e ",series[j][i-inddelay[rundel++]]);
+ }
+ fprintf(fout,"\n");
+ }
+ fclose(fout);
+ }
+
+ if (formatlist != NULL)
+ free(formatlist);
+ if (delaylist != NULL)
+ free(delaylist);
+ free(inddelay);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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: Dec 17, 1999 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <limits.h>
+#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<length;i++) {
+ x[2]=series[which][i];
+ if (maxima) {
+ if ((x[1] >= 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<dim;j++) {
+ a=series[j][i-1];
+ b=(series[j][i]-series[j][i-2])/2.0;
+ c=(series[j][i]-2.0*series[j][i-1]+series[j][i-2])/2.0;
+ if (!stdo)
+ fprintf(fout,"%e ",a+b*time+c*sqr(time));
+ else
+ fprintf(stdout,"%e ",a+b*time+c*sqr(time));
+ }
+ if (!stdo)
+ fprintf(fout,"%e\n",nexttime-lasttime);
+ else
+ fprintf(stdout,"%e\n",nexttime-lasttime);
+ lasttime=nexttime;
+ }
+ }
+ }
+ else {
+ if ((x[1] <= 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<dim;j++) {
+ a=series[j][i-1];
+ b=(series[j][i]-series[j][i-2])/2.0;
+ c=(series[j][i]-2.0*series[j][i-1]+series[j][i-2])/2.0;
+ if (!stdo)
+ fprintf(fout,"%e ",a+b*time+c*sqr(time));
+ else
+ fprintf(stdout,"%e ",a+b*time+c*sqr(time));
+ }
+ if (!stdo)
+ fprintf(fout,"%e\n",nexttime-lasttime);
+ else
+ fprintf(stdout,"%e\n",nexttime-lasttime);
+ lasttime=nexttime;
+ }
+ }
+ }
+ x[0]=x[1];
+ x[1]=x[2];
+ }
+ if (!stdo)
+ fclose(fout);
+
+ if (infile != NULL)
+ free(infile);
+ if (outfile != NULL)
+ free(outfile);
+ for (i=0;i<dim;i++)
+ free(series[i]);
+ free(series);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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: Dec 10, 2005 */
+/*Changes:
+ 12/10/05: It's multivariate now
+ 12/16/05: Scaled <eps> and sigma(eps)
+*/
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include <math.h>
+#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<BOX;x++)
+ for (y=0;y<BOX;y++)
+ box[x][y] = -1;
+
+ for (i=0;i<length-(maxemb+1)*delay;i++) {
+ x=(long)(series[0][i]/eps)&ibox;
+ y=(long)(series[hdim][i+hemb]/eps)&ibox;
+ list[i]=box[x][y];
+ box[x][y]=i;
+ }
+}
+
+char find_nearest(long n,unsigned int dim,double eps)
+{
+ long x,y,x1,x2,y1,i,i1,ic,ie;
+ long element,which= -1;
+ double dx,maxdx,mindx=1.1,hfactor,factor;
+
+ ic=vcomp[dim];
+ ie=vemb[dim];
+ x=(long)(series[0][n]/eps)&ibox;
+ y=(long)(series[ic][n+ie]/eps)&ibox;
+
+ for (x1=x-1;x1<=x+1;x1++) {
+ x2=x1&ibox;
+ for (y1=y-1;y1<=y+1;y1++) {
+ element=box[x2][y1&ibox];
+ while (element != -1) {
+ if (labs(element-n) > 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;i<comp;i++) {
+ rescale_data(series[i],length,&min,&ind_inter);
+ variance(series[i],length,&av,&ind_var);
+ if (i == 0) {
+ varianz=ind_var;
+ inter=ind_inter;
+ }
+ else {
+ varianz=(varianz>ind_var)?ind_var:varianz;
+ inter=(inter<ind_inter)?ind_inter:inter;
+ }
+ }
+
+ check_alloc(list=(long*)malloc(sizeof(long)*length));
+ check_alloc(nearest=(char*)malloc(length));
+ check_alloc(box=(long**)malloc(sizeof(long*)*BOX));
+ for (i=0;i<BOX;i++)
+ check_alloc(box[i]=(long*)malloc(sizeof(long)*BOX));
+
+ 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(vcomp=(unsigned int*)malloc(sizeof(int)*(maxdim)));
+ check_alloc(vemb=(unsigned int*)malloc(sizeof(int)*(maxdim)));
+ for (i=0;i<maxdim;i++) {
+ if (comp == 1) {
+ vcomp[i]=0;
+ vemb[i]=i;
+ }
+ else {
+ vcomp[i]=i%comp;
+ vemb[i]=(i/comp)*delay;
+ }
+ }
+ for (emb=minemb;emb<=maxemb;emb++) {
+ dim=emb*comp-1;
+ epsilon=eps0;
+ toolarge=0;
+ alldone=0;
+ donesofar=0;
+ aveps=0.0;
+ vareps=0.0;
+ for (i=0;i<length;i++)
+ nearest[i]=0;
+ if (verbosity&VER_USR1)
+ fprintf(stderr,"Start for dimension=%u\n",dim+1);
+ while (!alldone && (epsilon < 2.*varianz/rt)) {
+ alldone=1;
+ mmb(vcomp[dim],vemb[dim],epsilon);
+ for (i=0;i<length-maxemb*delay;i++)
+ if (!nearest[i]) {
+ nearest[i]=find_nearest(i,dim,epsilon);
+ alldone &= nearest[i];
+ donesofar += (unsigned long)nearest[i];
+ }
+ if (verbosity&VER_USR1)
+ fprintf(stderr,"Found %lu up to epsilon=%e\n",donesofar,epsilon*inter);
+ epsilon*=sqrt(2.0);
+ if (!donesofar)
+ eps0=epsilon;
+ }
+ if (donesofar == 0) {
+ fprintf(stderr,"Not enough points found!\n");
+ exit(FALSE_NEAREST_NOT_ENOUGH_POINTS);
+ }
+ aveps *= (1./(double)donesofar);
+ vareps *= (1./(double)donesofar);
+ if (stdo) {
+ fprintf(stdout,"%u %e %e %e\n",dim+1,(double)toolarge/(double)donesofar,
+ aveps*inter,sqrt(vareps)*inter);
+ fflush(stdout);
+ }
+ else {
+ fprintf(file,"%u %e %e %e\n",dim+1,(double)toolarge/(double)donesofar,
+ aveps*inter,sqrt(vareps)*inter);
+ fflush(file);
+ }
+ }
+ if (!stdo)
+ fclose(file);
+
+ if (infile != NULL)
+ free(infile);
+ if (outfile != NULL)
+ free(outfile);
+ free(series);
+ free(list);
+ free(nearest);
+ for (i=0;i<BOX;i++)
+ free(box[i]);
+ free(box);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <limits.h>
+#include <string.h>
+#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<NMAX;i++)
+ for (j=0;j<NMAX;j++)
+ box[i][j]= -1;
+
+ del=delay*(dim-1);
+ for (i=0;i<length-del;i++) {
+ x=(int)(series[i]*epsinv)&nmax;
+ y=(int)(series[i+del]*epsinv)&nmax;
+ list[i]=box[x][y];
+ box[x][y]=i;
+ }
+}
+
+char make_iterate(long act)
+{
+ char ok=0;
+ int x,y,i,j,i1,k,del1=dim*delay,which;
+ long element,minelement= -1;
+ double dx=0.0,mindx=2.0,stime;
+
+ x=(int)(series[act]*epsinv)&nmax;
+ y=(int)(series[act+delay*(dim-1)]*epsinv)&nmax;
+ for (i=x-1;i<=x+1;i++) {
+ i1=i&nmax;
+ for (j=y-1;j<=y+1;j++) {
+ element=box[i1][j&nmax];
+ while (element != -1) {
+ if (labs(act-element) > mindist) {
+ for (k=0;k<del1;k+=delay) {
+ dx = fabs(series[act+k]-series[element+k]);
+ if (dx > 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<howmany-1;i++) {
+ stime=0;
+ while ((dx=fabs(series[act]-series[minelement])) < data[i+1].eps) {
+ act++;
+ minelement++;
+ if ((act >= 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<howmany;i++) {
+ data[i].time=data[i].factor=0.0;
+ data[i].eps= (eps *= epsfactor);
+ data[i].count=0;
+ }
+
+ check_alloc(list=(long*)malloc(length*sizeof(long)));
+ check_alloc(done=(char*)malloc(length));
+
+ for (i=0;i<length;i++)
+ done[i]=0;
+
+ maxlength=length-delay*(dim-1)-1-mindist;
+ alldone=0;
+ for (eps=eps0;(eps<=epsmax) && (!alldone);eps*=epsfactor) {
+ epsinv=1.0/eps;
+ put_in_boxes();
+ alldone=1;
+ for (n=0;n<=maxlength;n++) {
+ if (!done[n])
+ done[n]=make_iterate(n);
+ alldone &= done[n];
+ }
+ }
+ if (!stdo) {
+ file=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ for (i=0;i<howmany;i++)
+ if (data[i].factor > 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<howmany;i++)
+ if (data[i].factor > 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;
+}
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <limits.h>
+#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<dim;i++)
+ n[i]=i;
+
+ for (i=0;i<dim-1;i++)
+ for (j=i+1;j<dim;j++)
+ if (x[j] > 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<BOX;x++)
+ for (y=0;y<BOX;y++)
+ box[x][y] = -1;
+
+ for (i=emb_offset;i<length;i++) {
+ x=(int)(series[0][i]*ieps)&ibox;
+ y=(int)(series[comp-1][i-emb_offset]*ieps)&ibox;
+ list[i]=box[x][y];
+ box[x][y]=i;
+ }
+}
+
+unsigned long fmn(long which,double eps)
+{
+ unsigned long nf=0;
+ long i,i1,i2,j,j1,k,k1,li;
+ long element;
+ double dx=0.0;
+
+ i=(int)(series[0][which]/eps)&ibox;
+ j=(int)(series[comp-1][which-emb_offset]/eps)&ibox;
+
+ for (i1=i-1;i1<=i+1;i1++) {
+ i2=i1&ibox;
+ for (j1=j-1;j1<=j+1;j1++) {
+ element=box[i2][j1&ibox];
+ while (element != -1) {
+ for (k=0;k<embed;k++) {
+ k1= -k*(int)delay;
+ for (li=0;li<comp;li++) {
+ dx=fabs(series[li][which+k1]-series[li][element+k1]);
+ if (dx > 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<dim;i++) {
+ i1=index_comp[i];
+ i2=index_embed[i];
+ help=0.0;
+ for (j=0;j<nf;j++)
+ help += series[i1][flist[j]-i2];
+ av[i]=help/nf;
+ }
+
+ for (i=0;i<dim;i++) {
+ i1=index_comp[i];
+ i2=index_embed[i];
+ for (j=i;j<dim;j++) {
+ help=0.0;
+ j1=index_comp[j];
+ j2=index_embed[j];
+ for (k=0;k<nf;k++) {
+ hs=flist[k];
+ help += series[i1][hs-i2]*series[j1][hs-j2];
+ }
+ mat[i][j]=(help/nf-av[i]*av[j])*metric[i]*metric[j];
+ mat[j][i]=mat[i][j];
+ }
+ }
+
+ eigen(mat,(unsigned long)dim,eig);
+ sort(eig,sorted);
+
+ for (i=0;i<dim;i++) {
+ help=0.0;
+ for (j=qdim;j<dim;j++) {
+ hs=sorted[j];
+ for (k=0;k<dim;k++) {
+ k1=index_comp[k];
+ k2=index_embed[k];
+ help += (series[k1][n-k2]-av[k])*mat[k][hs]*mat[i][hs]*metric[k];
+ }
+ }
+ corr[n][i]=help/metric[i];
+ }
+}
+
+void handle_trend(unsigned long n,unsigned long nf)
+{
+ long i,i1,i2,j;
+ double help;
+
+ for (i=0;i<dim;i++) {
+ help=0.0;
+ for (j=0;j<nf;j++)
+ help += corr[flist[j]][i];
+ av[i]=help/nf;
+ }
+
+ for (i=0;i<dim;i++) {
+ i1=index_comp[i];
+ i2=index_embed[i];
+ delta[i1][n-i2] += (corr[n][i]-av[i])/(trace*metric[i]);
+ }
+}
+
+void set_correction(void)
+{
+ long i,j;
+ double *hav,*hsigma,help;
+
+ check_alloc(hav=(double*)malloc(sizeof(double)*comp));
+ check_alloc(hsigma=(double*)malloc(sizeof(double)*comp));
+ for (j=0;j<comp;j++)
+ hav[j]=hsigma[j]=0.0;
+
+ for (i=0;i<length;i++)
+ for (j=0;j<comp;j++) {
+ hav[j] += (help=delta[j][i]);
+ hsigma[j] += help*help;
+ }
+
+ for (j=0;j<comp;j++) {
+ hav[j] /= length;
+ hsigma[j]=sqrt(fabs(hsigma[j]/length-hav[j]*hav[j]));
+ }
+ if (verbosity&(VER_USR1|VER_USR2)) {
+ for (i=0;i<comp;i++) {
+ fprintf(stderr,"Average shift of component %ld = %e\n",i+1,
+ hav[i]*d_max[i]);
+ fprintf(stderr,"Average rms correction of comp. %ld = %e\n\n",
+ i+1,hsigma[i]*d_max[i]);
+ }
+ }
+ for (i=0;i<length;i++)
+ for (j=0;j<comp;j++)
+ series[j][i] -= delta[j][i];
+
+ if (resize_eps) {
+ mineps /= epsfac;
+ if (verbosity&VER_USR2)
+ fprintf(stderr,"Reset minimal neighbourhood size to %e\n",
+ mineps*d_max_max);
+ }
+
+ resize_eps=0;
+ free(hav);
+ free(hsigma);
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0;
+ int iter,epscount,*ok;
+ long i,j;
+ char all_done;
+ char *ofname;
+ unsigned long nfound,n,allfound;
+ double epsilon;
+ double **hser;
+ 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
+
+ dim=comp*embed;
+ emb_offset=(embed-1)*delay;
+
+ 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));
+ check_alloc(ofname=(char*)calloc(strlen(infile)+9,(size_t)1));
+ sprintf(outfile,"%s.opt",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.opt");
+ }
+ }
+ else
+ check_alloc(ofname=(char*)calloc(strlen(outfile)+10,(size_t)1));
+
+ 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);
+
+ if (length < minn) {
+ fprintf(stderr,"With %lu data you will never find %u neighbors."
+ " Exiting!\n",length,minn);
+ exit(GHKSS__TOO_MANY_NEIGHBORS);
+ }
+
+ check_alloc(d_min=(double*)malloc(sizeof(double)*comp));
+ check_alloc(d_max=(double*)malloc(sizeof(double)*comp));
+ d_max_max=0.0;
+ for (i=0;i<comp;i++) {
+ rescale_data(series[i],length,&d_min[i],&d_max[i]);
+ if (d_max[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<BOX;i++)
+ check_alloc(box[i]=(long*)malloc(sizeof(long)*BOX));
+
+ check_alloc(list=(long*)malloc(sizeof(long)*length));
+ check_alloc(flist=(unsigned long*)malloc(sizeof(long)*length));
+
+ check_alloc(metric=(double*)malloc(sizeof(double)*dim));
+ trace=0.0;
+ if (euclidean) {
+ for (i=0;i<dim;i++) {
+ metric[i]=1.0;
+ trace += 1./metric[i];
+ }
+ }
+ else {
+ for (i=0;i<dim;i++) {
+ if ((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<length;i++)
+ check_alloc(corr[i]=(double*)malloc(sizeof(double)*dim));
+ check_alloc(ok=(int*)malloc(sizeof(int)*length));
+ check_alloc(delta=(double**)malloc(sizeof(double*)*comp));
+ for (i=0;i<comp;i++)
+ check_alloc(delta[i]=(double*)malloc(sizeof(double)*length));
+ check_alloc(index_comp=(unsigned int*)malloc(sizeof(int)*dim));
+ check_alloc(index_embed=(unsigned int*)malloc(sizeof(int)*dim));
+ check_alloc(av=(double*)malloc(sizeof(double)*dim));
+ check_alloc(sorted=(int*)malloc(sizeof(int)*dim));
+ check_alloc(eig=(double*)malloc(sizeof(double)*dim));
+ check_alloc(matarray=(double*)malloc(sizeof(double)*dim*dim));
+ check_alloc(mat=(double**)malloc(sizeof(double*)*dim));
+ for (i=0;i<dim;i++)
+ mat[i]=(double*)(matarray+dim*i);
+ check_alloc(hser=(double**)malloc(sizeof(double*)*comp));
+
+ for (i=0;i<dim;i++) {
+ index_comp[i]=i%comp;
+ index_embed[i]=(i/comp)*delay;
+ }
+
+ resize_eps=0;
+ for (iter=1;iter<=iterations;iter++) {
+ for (i=0;i<length;i++) {
+ ok[i]=0;
+ for (j=0;j<dim;j++)
+ corr[i][j]=0.0;
+ for (j=0;j<comp;j++)
+ delta[j][i]=0.0;
+ }
+ epsilon=mineps;
+ all_done=0;
+ epscount=1;
+ allfound=0;
+ if (verbosity&(VER_USR1|VER_USR2))
+ fprintf(stderr,"Starting iteration %d\n",iter);
+ while(!all_done) {
+ mmb(epsilon);
+ all_done=1;
+ for (n=emb_offset;n<length;n++)
+ if (!ok[n]) {
+ nfound=fmn(n,epsilon);
+ if (nfound >= 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<epscount;i++) {
+ mmb(epsilon);
+ for (n=emb_offset;n<length;n++)
+ if (ok[n] == i) {
+ nfound=fmn(n,epsilon);
+ handle_trend(n,nfound);
+ allfound++;
+ }
+ if (verbosity&VER_USR2)
+ fprintf(stderr,"Trend subtracted for %ld points with epsilon= %e\n",
+ allfound,epsilon*d_max_max);
+ epsilon *= epsfac;
+ }
+ set_correction();
+
+ sprintf(ofname,"%s.%d",outfile,iter);
+ test_outfile(ofname);
+
+ file=fopen(ofname,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n\n",ofname);
+ for (i=0;i<length;i++) {
+ for (j=0;j<comp;j++) {
+ fprintf(file,"%e ",series[j][i]*d_max[j]+d_min[j]);
+ }
+ fprintf(file,"\n");
+ if (stdo && (iter == iterations)) {
+ for (j=0;j<comp;j++)
+ fprintf(stdout,"%e ",series[j][i]*d_max[j]+d_min[j]);
+ fprintf(stdout,"\n");
+ }
+ }
+ fclose(file);
+ }
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 Dec 6, 2005*/
+/*Changes:
+ 12/06/05: shift output x value to center of interval
+*/
+#include <math.h>
+#include <limits.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#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<base;i++)
+ box[i]=0;
+ size=1./base;
+ size2=size/2.0;
+ for (i=0;i<length;i++) {
+ if (series[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<base;i++) {
+ x=(double)(i*size);
+ fprintf(fout,"%e %e\n",(x+size2)*max+min,(double)box[i]*norm);
+ }
+ fclose(fout);
+ }
+ else {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Writing to stdout\n");
+ fprintf(stdout,"#interval of data: [%e:%e]\n",min,max+min);
+ fprintf(stdout,"#average= %e\n",average);
+ fprintf(stdout,"#standard deviation= %e\n",var);
+ for (i=0;i<base;i++) {
+ x=(double)(i*size);
+ fprintf(stdout,"%e %e\n",(x+size2)*max+min,(double)box[i]*norm);
+ fflush(stdout);
+ }
+ }
+ return 0;
+}
--- /dev/null
+/*
+ * 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 21, 2005 */
+/*changes:
+ Jun 17, 2005: Comments in the output file updated
+ Jun 21, 2005: free imat in make_fit
+*/
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include "routines/tsa.h"
+#include <math.h>
+
+#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<dim*embed;i++) {
+ hvec[i]=0.0;
+ for (j=0;j<dim*embed;j++)
+ hvec[i] += mat[i][j]*vec[j];
+ }
+ for (i=0;i<dim*embed;i++)
+ vec[i]=hvec[i];
+}
+
+void make_fit(long act,unsigned long number)
+{
+ double *si,*sj,lavi,lavj,fav,**imat,cast;
+ long i,i1,hi,hi1,j,j1,hj,hj1,n,which;
+
+ for (i=0;i<embed*dim;i++)
+ localav[i]=0;
+ for (i=0;i<dim;i++)
+ foreav[i]=0.0;
+
+ for (n=0;n<number;n++) {
+ which=found[n];
+ for (j=0;j<dim;j++) {
+ sj=series[j];
+ foreav[j] += sj[which+STEP];
+ for (j1=0;j1<embed;j1++) {
+ hj=j*embed+j1;
+ localav[hj] += sj[which-j1*delay];
+ }
+ }
+ }
+
+ for (i=0;i<dim*embed;i++)
+ localav[i] /= number;
+ for (i=0;i<dim;i++)
+ foreav[i] /= number;
+
+ for (i=0;i<dim;i++) {
+ si=series[i];
+ for (i1=0;i1<embed;i1++) {
+ hi=i*embed+i1;
+ lavi=localav[hi];
+ hi1=i1*delay;
+ for (j=0;j<dim;j++) {
+ sj=series[j];
+ for (j1=0;j1<embed;j1++) {
+ hj=j*embed+j1;
+ lavj=localav[hj];
+ hj1=j1*delay;
+ mat[hi][hj]=0.0;
+ if (hj >= hi) {
+ for (n=0;n<number;n++) {
+ which=found[n];
+ mat[hi][hj] += (si[which-hi1]-lavi)*(sj[which-hj1]-lavj);
+ }
+ }
+ }
+ }
+ }
+ }
+
+ for (i=0;i<dim*embed;i++)
+ for (j=i;j<dim*embed;j++) {
+ mat[i][j] /= number;
+ mat[j][i]=mat[i][j];
+ }
+
+ imat=invert_matrix(mat,dim*embed);
+
+ for (i=0;i<dim;i++) {
+ si=series[i];
+ fav=foreav[i];
+ for (j=0;j<dim;j++) {
+ sj=series[j];
+ for (j1=0;j1<embed;j1++) {
+ hj=j*embed+j1;
+ lavj=localav[hj];
+ hj1=j1*delay;
+ vec[hj]=0.0;
+ for (n=0;n<number;n++) {
+ which=found[n];
+ vec[hj] += (si[which+STEP]-fav)*(sj[which-hj1]-lavj);
+ }
+ vec[hj] /= number;
+ }
+ }
+
+ multiply_matrix(imat,vec);
+
+ cast=foreav[i];
+ for (j=0;j<dim;j++) {
+ sj=series[j];
+ for (j1=0;j1<embed;j1++) {
+ hj=j*embed+j1;
+ cast += vec[hj]*(sj[act-j1*delay]-localav[hj]);
+ }
+ }
+ error[i] += sqr(cast-series[i][act+STEP]);
+ }
+ for (i=0;i<embed*dim;i++)
+ free(imat[i]);
+ free(imat);
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0;
+ unsigned long actfound;
+ unsigned long *hfound;
+ long pfound,i,j;
+ unsigned long clength;
+ double interval,min,maxinterval;
+ double epsilon;
+ double **hser;
+ double avfound,*hrms,*hav,sumerror=0.0;
+ 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
+
+ if (!causalset)
+ causal=STEP;
+
+ 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.ll",infile);
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)9,(size_t)1));
+ sprintf(outfile,"stdin.ll");
+ }
+ }
+ if (!stdo)
+ test_outfile(outfile);
+
+ 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);
+ maxinterval=0.0;
+ for (i=0;i<dim;i++) {
+ rescale_data(series[i],LENGTH,&min,&interval);
+ if (interval > 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<NMAX;i++)
+ check_alloc(box[i]=(long*)malloc(sizeof(long)*NMAX));
+ check_alloc(vec=(double*)malloc(sizeof(double)*(embed*dim)));
+ check_alloc(hvec=(double*)malloc(sizeof(double)*(embed*dim)));
+ check_alloc(mat=(double**)malloc(sizeof(double*)*(embed*dim)));
+ for (i=0;i<dim*embed;i++)
+ check_alloc(mat[i]=(double*)malloc(sizeof(double)*(embed*dim)));
+ check_alloc(error=(double*)malloc(sizeof(double)*dim));
+ check_alloc(hrms=(double*)malloc(sizeof(double)*dim));
+ check_alloc(hav=(double*)malloc(sizeof(double)*dim));
+ check_alloc(hser=(double**)malloc(sizeof(double*)*dim));
+ check_alloc(foreav=(double*)malloc(sizeof(double)*dim));
+ check_alloc(localav=(double*)malloc(sizeof(double)*(embed*dim)));
+
+ if (eps0set)
+ EPS0 /= interval;
+ if (eps1set)
+ EPS1 /= interval;
+
+ clength=(CLENGTH <= LENGTH) ? CLENGTH-STEP : LENGTH-STEP;
+
+ if (!stdo) {
+ file=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ fprintf(file,"#1.) neighborhood size\n");
+ fprintf(file,"#2.) average relative forecast error\n");
+ fprintf(file,"#next n.) relative forecast error of the n components\n");
+ fprintf(file,"#second last.) fraction of points with enough neighbors\n");
+ fprintf(file,"#last .) average number of neighbors used for the fit\n");
+ }
+ else {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Writing to stdout\n");
+ }
+
+ for (epsilon=EPS0;epsilon<EPS1*EPSF;epsilon*=EPSF) {
+ pfound=0;
+ for (i=0;i<dim;i++)
+ error[i]=hrms[i]=hav[i]=0.0;
+ avfound=0.0;
+ make_multi_box(series,box,list,LENGTH-STEP,NMAX,dim,
+ embed,delay,epsilon);
+ for (i=(embed-1)*delay;i<clength;i++) {
+ for (j=0;j<dim;j++)
+ hser[j]=series[j]+i;
+ actfound=find_multi_neighbors(series,box,list,hser,LENGTH,
+ NMAX,dim,embed,delay,epsilon,hfound);
+ actfound=exclude_interval(actfound,i-causal+1,i+causal+(embed-1)*delay-1,
+ hfound,found);
+ if (actfound > 2*(dim*embed+1)) {
+ make_fit(i,actfound);
+ pfound++;
+ avfound += (double)(actfound-1);
+ for (j=0;j<dim;j++) {
+ hrms[j] += series[j][i+STEP]*series[j][i+STEP];
+ hav[j] += series[j][i+STEP];
+ }
+ }
+ }
+ if (pfound > 1) {
+ sumerror=0.0;
+ for (j=0;j<dim;j++) {
+ hav[j] /= pfound;
+ hrms[j]=sqrt(fabs(hrms[j]/(pfound-1)-hav[j]*hav[j]*pfound/(pfound-1)));
+ error[j]=sqrt(error[j]/pfound)/hrms[j];
+ sumerror += error[j];
+ }
+ }
+ if (stdo) {
+ if (pfound > 1) {
+ fprintf(stdout,"%e %e ",epsilon*interval,sumerror/(double)dim);
+ for (j=0;j<dim;j++)
+ fprintf(stdout,"%e ",error[j]);
+ fprintf(stdout,"%e %e\n",(double)pfound/(clength-(embed-1)*delay),
+ avfound/pfound);
+ fflush(stdout);
+ }
+ }
+ else {
+ if (pfound > 1) {
+ fprintf(file,"%e %e ",epsilon*interval,sumerror/(double)dim);
+ for (j=0;j<dim;j++)
+ fprintf(file,"%e ",error[j]);
+ fprintf(file,"%e %e\n",(double)pfound/(clength-(embed-1)*delay),
+ avfound/pfound);
+ fflush(file);
+ }
+ }
+ }
+ if (!stdo)
+ fclose(file);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 29, 2000 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include <math.h>
+#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;i<NMAX;i++)
+ for (j=0;j<NMAX;j++)
+ box[i][j]= -1;
+
+ for (n=hdim;n<LENGTH-1;n++) {
+ i=(int)(series[0][n]*epsinv)&nmax;
+ j=(int)(series[dim1][n-hdim]*epsinv)&nmax;
+ list[n]=box[i][j];
+ box[i][j]=n;
+ }
+}
+
+unsigned int hfind_neighbors(void)
+{
+ char toolarge;
+ int i,j,i1,i2,j1,k,l,element;
+ static int hdim;
+ unsigned nfound=0;
+ double max,dx,epsinv;
+
+ hdim=(embed-1)*DELAY;
+ epsinv=1.0/epsilon;
+ i=(int)(cast[hdim][0]*epsinv)&nmax;
+ j=(int)(cast[0][dim1]*epsinv)&nmax;
+
+ for (i1=i-1;i1<=i+1;i1++) {
+ i2=i1&nmax;
+ for (j1=j-1;j1<=j+1;j1++) {
+ element=box[i2][j1&nmax];
+ while (element != -1) {
+ max=0.0;
+ toolarge=0;
+ for (l=0;l<dim;l++) {
+ for (k=0;k<=hdim;k += DELAY) {
+ dx=fabs(series[l][element-k]-cast[hdim-k][l]);
+ max=(dx>max) ? 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<dim*embed;i++) {
+ hvec[i]=0.0;
+ for (j=0;j<dim*embed;j++)
+ hvec[i] += mat[i][j]*vec[j];
+ }
+ for (i=0;i<dim*embed;i++)
+ vec[i]=hvec[i];
+ free(hvec);
+}
+
+void make_fit(int number,double *newcast)
+{
+ double *sj,*si,lavi,lavj,fav;
+ long i,i1,j,j1,hi,hj,hi1,hj1,n,which;
+ static int hdim;
+
+ hdim=(embed-1)*DELAY;
+
+ for (i=0;i<dim*embed;i++)
+ localav[i]=0.0;
+ for (i=0;i<dim;i++)
+ foreav[i]=0.0;
+
+ for (n=0;n<number;n++) {
+ which=found[n];
+ for (j=0;j<dim;j++) {
+ sj=series[j];
+ foreav[j] += sj[which+1];
+ for (j1=0;j1<embed;j1++) {
+ hj=j*embed+j1;
+ localav[hj] += sj[which-j1*DELAY];
+ }
+ }
+ }
+
+ for (i=0;i<dim*embed;i++)
+ localav[i] /= number;
+ for (i=0;i<dim;i++)
+ foreav[i] /= number;
+
+ for (i=0;i<dim;i++) {
+ si=series[i];
+ for (i1=0;i1<embed;i1++) {
+ hi=i*embed+i1;
+ lavi=localav[hi];
+ hi1=i1*DELAY;
+ for (j=0;j<dim;j++) {
+ sj=series[j];
+ for (j1=0;j1<embed;j1++) {
+ hj=j*embed+j1;
+ lavj=localav[hj];
+ hj1=j1*DELAY;
+ mat[hi][hj]=0.0;
+ if (hj >= hi) {
+ for (n=0;n<number;n++) {
+ which=found[n];
+ mat[hi][hj] += (si[which-hi1]-lavi)*(sj[which-hj1]-lavj);
+ }
+ }
+ }
+ }
+ }
+ }
+
+ for (i=0;i<dim*embed;i++)
+ for (j=i;j<dim*embed;j++) {
+ mat[i][j] /= number;
+ mat[j][i]=mat[i][j];
+ }
+
+ imat=invert_matrix(mat,dim*embed);
+
+ for (i=0;i<dim;i++) {
+ si=series[i];
+ fav=foreav[i];
+ for (j=0;j<dim;j++) {
+ sj=series[j];
+ for (j1=0;j1<embed;j1++) {
+ hj=j*embed+j1;
+ lavj=localav[hj];
+ hj1=j1*DELAY;
+ vec[hj]=0.0;
+ for (n=0;n<number;n++) {
+ which=found[n];
+ vec[hj] += (si[which+1]-fav)*(sj[which-hj1]-lavj);
+ }
+ vec[hj] /= number;
+ }
+ }
+
+ multiply_matrix(imat,vec);
+
+ newcast[i]=foreav[i];
+ for (j=0;j<dim;j++) {
+ for (j1=0;j1<embed;j1++) {
+ hj=j*embed+j1;
+ newcast[i] += vec[hj]*(cast[hdim-j1*DELAY][j]-localav[hj]);
+ }
+ }
+ }
+
+ for (i=0;i<dim*embed;i++)
+ free(imat[i]);
+ free(imat);
+}
+
+void make_zeroth(int number,double *newcast)
+{
+ unsigned long i,d;
+ double *sj;
+
+ for (d=0;d<dim;d++) {
+ newcast[d]=0.0;
+ sj=series[d]+1;
+ for (i=0;i<number;i++)
+ newcast[d] += sj[found[i]];
+ newcast[d] /= number;
+ }
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0,done;
+ long i,j,hdim,actfound;
+ double maxinterval,*swap,*newcast;
+ 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,NULL,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,".cast");
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)11,(size_t)1));
+ strcpy(outfile,"stdin.cast");
+ }
+ }
+ if (!onscreen)
+ test_outfile(outfile);
+
+ hdim=(embed-1)*DELAY+1;
+ 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);
+ check_alloc(min=(double*)malloc(sizeof(double)*dim));
+ check_alloc(interval=(double*)malloc(sizeof(double)*dim));
+ dim1=dim-1;
+ maxinterval=0.0;
+ for (i=0;i<dim;i++) {
+ rescale_data(series[i],LENGTH,&min[i],&interval[i]);
+ if (interval[i] > maxinterval)
+ maxinterval=interval[i];
+ }
+
+ check_alloc(cast=(double**)malloc(sizeof(double*)*hdim));
+ for (i=0;i<hdim;i++)
+ check_alloc(cast[i]=(double*)malloc(sizeof(double)*dim));
+ check_alloc(newcast=(double*)malloc(sizeof(double)*dim));
+
+ check_alloc(list=(long*)malloc(sizeof(long)*LENGTH));
+ check_alloc(found=(long*)malloc(sizeof(long)*LENGTH));
+ check_alloc(box=(long**)malloc(sizeof(long*)*NMAX));
+ for (i=0;i<NMAX;i++)
+ check_alloc(box[i]=(long*)malloc(sizeof(long)*NMAX));
+
+ check_alloc(localav=(double*)malloc(sizeof(double)*dim*embed));
+ check_alloc(foreav=(double*)malloc(sizeof(double)*dim));
+ check_alloc(vec=(double*)malloc(sizeof(double)*dim*embed));
+ check_alloc(mat=(double**)malloc(sizeof(double*)*dim*embed));
+ for (i=0;i<dim*embed;i++)
+ check_alloc(mat[i]=(double*)malloc(sizeof(double)*dim*embed));
+
+ if (epsset)
+ EPS0 /= maxinterval;
+
+ for (j=0;j<dim;j++)
+ for (i=0;i<hdim;i++)
+ cast[i][j]=series[j][LENGTH-hdim+i];
+
+ if (!onscreen) {
+ 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");
+ }
+
+ for (i=0;i<FLENGTH;i++) {
+ done=0;
+ epsilon=EPS0/EPSF;
+ while (!done) {
+ epsilon*=EPSF;
+ put_in_boxes();
+ actfound=hfind_neighbors();
+ if (actfound >= MINN) {
+ if (!do_zeroth)
+ make_fit(actfound,newcast);
+ else
+ make_zeroth(actfound,newcast);
+ if (onscreen) {
+ for (j=0;j<dim-1;j++)
+ printf("%e ",newcast[j]*interval[j]+min[j]);
+ printf("%e\n",newcast[dim-1]*interval[dim-1]+min[dim-1]);
+ fflush(stdout);
+ }
+ else {
+ for (j=0;j<dim-1;j++)
+ fprintf(file,"%e ",newcast[j]*interval[j]+min[j]);
+ fprintf(file,"%e\n",newcast[dim-1]*interval[dim-1]+min[dim-1]);
+ fflush(file);
+ }
+ done=1;
+ for (j=0;j<dim;j++) {
+ if ((newcast[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<hdim-1;j++)
+ cast[j]=cast[j+1];
+ cast[hdim-1]=swap;
+ for (j=0;j<dim;j++)
+ cast[hdim-1][j]=newcast[j];
+ }
+ }
+ }
+ if (!onscreen)
+ fclose(file);
+
+ if (outfile != NULL)
+ free(outfile);
+ for (i=0;i<embed*dim;i++)
+ free(mat[i]);
+ free(mat);
+ for (i=0;i<hdim;i++)
+ free(cast[i]);
+ free(cast);
+ free(newcast);
+ free(found);
+ free(list);
+ for (i=0;i<NMAX;i++)
+ free(box[i]);
+ free(box);
+ free(vec);
+ free(localav);
+ free(foreav);
+ free(min);
+ free(interval);
+ for (i=0;i<dim;i++)
+ free(series[i]);
+ free(series);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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:
+ Sep 8, 2006: Add -o functionality
+ Sep 7, 2006: Completely rewritten to handle multivariate data
+ */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include "routines/tsa.h"
+#include <math.h>
+
+#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;i<NMAX;i++)
+ for (j=0;j<NMAX;j++)
+ box[i][j]= -1;
+
+ for (n=hdim;n<LENGTH-STEP;n++) {
+ i=(int)(series[0][n]*epsinv)&nmax;
+ j=(int)(series[comp1][n-hdim]*epsinv)&nmax;
+ list[n]=box[i][j];
+ box[i][j]=n;
+ }
+}
+
+unsigned int hfind_neighbors(unsigned long act)
+{
+ char toolarge;
+ int i,j,i1,i2,j1,k,element;
+ unsigned long nfound=0;
+ unsigned int hcomp,hdel;
+ double max,dx,epsinv;
+
+ epsinv=1.0/epsilon;
+
+ i=(int)(series[0][act]*epsinv)&nmax;
+ j=(int)(series[comp1][act-hdim]*epsinv)&nmax;
+
+ for (i1=i-1;i1<=i+1;i1++) {
+ i2=i1&nmax;
+ for (j1=j-1;j1<=j+1;j1++) {
+ element=box[i2][j1&nmax];
+ while (element != -1) {
+ max=0.0;
+ toolarge=0;
+ for (k=0;k<DIM;k += 1) {
+ hcomp=indexes[0][k];
+ hdel=indexes[1][k];
+ dx=fabs(series[hcomp][element-hdel]-series[hcomp][act-hdel]);
+ max=(dx>max) ? 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<DIM;i++) {
+ hvec[i]=0.0;
+ for (j=0;j<DIM;j++)
+ hvec[i] += mat[i][j]*vec[j];
+ }
+ for (i=0;i<DIM;i++)
+ vec[i]=hvec[i];
+ free(hvec);
+}
+
+void make_fit(int number,unsigned long act,double *newcast)
+{
+ double *sj,*si,lavi,lavj,fav;
+ unsigned int hci,hdi,hcj,hdj;
+ long i,j,n,which;
+
+ for (i=0;i<DIM;i++)
+ localav[i]=0.0;
+ for (i=0;i<COMP;i++)
+ foreav[i]=0.0;
+
+ for (n=0;n<number;n++) {
+ which=found[n];
+ for (j=0;j<COMP;j++)
+ foreav[j] += series[j][which+STEP];
+ for (j=0;j<DIM;j++) {
+ hcj=indexes[0][j];
+ hdj=indexes[1][j];
+ localav[j] += series[hcj][which-hdj];
+ }
+ }
+
+ for (i=0;i<DIM;i++)
+ localav[i] /= number;
+ for (i=0;i<COMP;i++)
+ foreav[i] /= number;
+
+ for (i=0;i<DIM;i++) {
+ hci=indexes[0][i];
+ hdi=indexes[1][i];
+ lavi=localav[i];
+ si=series[hci];
+ for (j=i;j<DIM;j++) {
+ hcj=indexes[0][j];
+ hdj=indexes[1][j];
+ lavj=localav[j];
+ sj=series[hcj];
+ mat[i][j]=0.0;
+ for (n=0;n<number;n++) {
+ which=found[n];
+ mat[i][j] += (si[which-hdi]-lavi)*(sj[which-hdj]-lavj);
+ }
+ mat[i][j] /= number;
+ mat[j][i] = mat[i][j];
+ }
+ }
+
+ imat=invert_matrix(mat,DIM);
+
+ for (i=0;i<COMP;i++) {
+ si=series[i];
+ fav=foreav[i];
+ for (j=0;j<DIM;j++) {
+ hcj=indexes[0][j];
+ hdj=indexes[1][j];
+ lavj=localav[j];
+ vec[j]=0.0;
+ sj=series[hcj];
+ for (n=0;n<number;n++) {
+ which=found[n];
+ vec[j] += (si[which+STEP]-fav)*(sj[which-hdj]);
+ }
+ vec[j] /= number;
+ }
+
+ multiply_matrix(imat,vec);
+
+ newcast[i]=foreav[i];
+ for (j=0;j<DIM;j++) {
+ hcj=indexes[0][j];
+ hdj=indexes[1][j];
+ newcast[i] += vec[j]*(series[hcj][act-hdj]-localav[j]);
+ }
+ }
+
+
+ for (i=0;i<DIM;i++)
+ free(imat[i]);
+ free(imat);
+}
+
+int main(int argc,char **argv)
+{
+ char stin=0,alldone,*done;
+ long i,j;
+ unsigned long actfound;
+ unsigned long clength;
+ double *rms,*av,*min,*interval,maxinterval,norm;
+ double *error,**individual=NULL;
+ double *newcast;
+ FILE *fout;
+
+ if (scan_help(argc,argv))
+ show_options(argv[0]);
+
+ scan_options(argc,argv);
+
+ 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)
+ stin=1;
+
+ if (outfile == NULL) {
+ if (!stin) {
+ check_alloc(outfile=(char*)calloc(strlen(infile)+5,(size_t)1));
+ strcpy(outfile,infile);
+ strcat(outfile,".fce");
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1));
+ strcpy(outfile,"stdin.fce");
+ }
+ }
+ if (!stout)
+ 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);
+
+ if ((LENGTH-(EMBED-1)*DELAY) < MINN) {
+ fprintf(stderr,"Data set is too short to find enough neighbors "
+ "for the fit! Exiting!\n");
+ exit(ONESTEP_TOO_FEW_POINTS);
+ }
+
+ DIM=EMBED*COMP;
+ check_alloc(min=(double*)malloc(sizeof(double)*COMP));
+ check_alloc(interval=(double*)malloc(sizeof(double)*COMP));
+ check_alloc(av=(double*)malloc(sizeof(double)*COMP));
+ check_alloc(rms=(double*)malloc(sizeof(double)*COMP));
+
+ maxinterval=0.0;
+ for (i=0;i<COMP;i++) {
+ rescale_data(series[i],LENGTH,&min[i],&interval[i]);
+ maxinterval=(maxinterval<interval[i])?interval[i]:maxinterval;
+ variance(series[i],LENGTH,&av[i],&rms[i]);
+ }
+
+ if (verbosity&VER_USR1) {
+ check_alloc(individual=(double**)malloc(sizeof(double*)*COMP));
+ for (j=0;j<COMP;j++) {
+ check_alloc(individual[j]=(double*)malloc(sizeof(double)*LENGTH));
+ for (i=0;i<LENGTH;i++)
+ individual[j][i]=0.0;
+ }
+ }
+
+ 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(done=(char*)malloc(sizeof(char)*LENGTH));
+ check_alloc(box=(long**)malloc(sizeof(long*)*NMAX));
+ for (i=0;i<NMAX;i++)
+ check_alloc(box[i]=(long*)malloc(sizeof(long)*NMAX));
+
+ for (i=0;i<LENGTH;i++)
+ done[i]=0;
+
+ alldone=0;
+ if (epsset)
+ EPS0 /= maxinterval;
+
+ epsilon=EPS0/EPSF;
+ clength=(CLENGTH <= LENGTH) ? CLENGTH-STEP : LENGTH-STEP;
+ comp1=COMP-1;
+ indexes=make_multi_index(COMP,EMBED,DELAY);
+
+ hdim=(EMBED-1)*DELAY;
+ check_alloc(newcast=(double*)malloc(sizeof(double)*COMP));
+
+
+ check_alloc(localav=(double*)malloc(sizeof(double)*DIM));
+ check_alloc(foreav=(double*)malloc(sizeof(double)*COMP));
+ check_alloc(vec=(double*)malloc(sizeof(double)*DIM));
+ check_alloc(mat=(double**)malloc(sizeof(double*)*DIM));
+ for (i=0;i<=DIM;i++)
+ check_alloc(mat[i]=(double*)malloc(sizeof(double)*DIM));
+
+ check_alloc(error=(double*)malloc(sizeof(double)*COMP));
+ for (i=0;i<COMP;i++)
+ error[i]=0.0;
+
+ while (!alldone) {
+ alldone=1;
+ epsilon*=EPSF;
+ put_in_boxes() ;
+ for (i=(EMBED-1)*DELAY;i<clength;i++)
+ if (!done[i]) {
+ actfound=hfind_neighbors(i);
+ actfound=exclude_interval(actfound,i-causal+1,
+ i+causal+(EMBED-1)*DELAY-1,hfound,found);
+ if (actfound > MINN) {
+ make_fit(actfound,i,newcast);
+ for (j=0;j<COMP;j++)
+ error[j] += sqr(newcast[j]-series[j][i+STEP]);
+ if (verbosity&VER_USR1) {
+ for (j=0;j<COMP;j++)
+ individual[j][i]=(newcast[j]-series[j][i+STEP])*interval[j];
+ }
+ done[i]=1;
+ }
+ alldone &= done[i];
+ }
+ }
+ norm=((double)clength-(double)((EMBED-1)*DELAY));
+ if (stout) {
+ if (verbosity&VER_USR1) {
+ fprintf(stdout,"#Relative forecast errors for each component:\n");
+ for (i=0;i<COMP;i++)
+ fprintf(stdout,"# %e\n",sqrt(error[i]/norm)/rms[i]);
+
+ for (i=(EMBED-1)*DELAY;i<clength;i++) {
+ for (j=0;j<COMP-1;j++)
+ fprintf(stdout,"%e ",individual[j][i]);
+ fprintf(stdout,"%e\n",individual[COMP-1][i]);
+ }
+ }
+ else {
+ fprintf(stdout,"#Relative forecast errors for each component:\n");
+ for (i=0;i<COMP;i++)
+ fprintf(stdout,"%e\n",sqrt(error[i]/norm)/rms[i]);
+ }
+ }
+ else {
+ fout=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ if (verbosity&VER_USR1) {
+ fprintf(fout,"#Relative forecast errors for each component:\n");
+ for (i=0;i<COMP;i++)
+ fprintf(fout,"# %e\n",sqrt(error[i]/norm)/rms[i]);
+
+ for (i=(EMBED-1)*DELAY;i<clength;i++) {
+ for (j=0;j<COMP-1;j++)
+ fprintf(fout,"%e ",individual[j][i]);
+ fprintf(fout,"%e\n",individual[COMP-1][i]);
+ }
+ }
+ else {
+ fprintf(fout,"#Relative forecast errors for each component:\n");
+ for (i=0;i<COMP;i++)
+ fprintf(fout,"%e\n",sqrt(error[i]/norm)/rms[i]);
+ }
+ fclose(fout);
+ free(outfile);
+ }
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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: Dec 17, 2001 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <limits.h>
+#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<length-1;i++)
+ new[i]=(series[i-1]+2.0*series[i]+series[i+1])/4.0;
+ sprintf(ofname,"%s.%d",outfile,iter);
+ test_outfile(ofname);
+ file=fopen(ofname,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",ofname);
+ if (stdo && (iter == iterations)) {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Writing to stdout\n");
+ }
+ for (i=0;i<length;i++) {
+ if (stdo && (iter == iterations))
+ fprintf(stdout,"%e\n",series[i]=new[i]);
+ fprintf(file,"%e\n",series[i]=new[i]);
+ }
+ fclose(file);
+ }
+ }
+ else {
+ 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<length-1;i++)
+ new[i]=(series[i-1]+2.0*series[i]+series[i+1])/4.0;
+ for (i=0;i<length;i++)
+ series[i]=new[i];
+ }
+ if (!stdo) {
+ sprintf(ofname,"%s.%d",outfile,iterations);
+ file=fopen(ofname,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",ofname);
+ for (i=0;i<length;i++)
+ fprintf(file,"%e\n",series[i]);
+ fclose(file);
+ }
+ else {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Writing to stdout\n");
+ for (i=0;i<length;i++)
+ fprintf(stdout,"%e\n",series[i]);
+ }
+ }
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 <math.h>
+#include <limits.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#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<BOX;i++)
+ for (j=0;j<BOX;j++)
+ box[i][j]= -1;
+
+ for (i=0;i<blength;i++) {
+ j=(long)(series[i]/eps)&ibox;
+ k=(long)(series[i+delay]/eps)&ibox;
+ liste[i]=box[j][k];
+ box[j][k]=i;
+ }
+}
+
+void lfind_neighbors(long act,double eps)
+{
+ unsigned int hi,k,k1;
+ long i,j,i1,i2,j1,element;
+ static long lwindow;
+ double dx,eps2=sqr(eps);
+
+ lwindow=(long)window;
+ for (hi=0;hi<maxdim-1;hi++)
+ found[hi]=0;
+ i=(long)(series[act]/eps)&ibox;
+ j=(long)(series[act+delay]/eps)&ibox;
+ for (i1=i-1;i1<=i+1;i1++) {
+ i2=i1&ibox;
+ for (j1=j-1;j1<=j+1;j1++) {
+ element=box[i2][j1&ibox];
+ while (element != -1) {
+ if ((element < (act-lwindow)) || (element > (act+lwindow))) {
+ dx=sqr(series[act]-series[element]);
+ if (dx <= eps2) {
+ for (k=1;k<maxdim;k++) {
+ k1=k*delay;
+ dx += sqr(series[act+k1]-series[element+k1]);
+ if (dx <= eps2) {
+ k1=k-1;
+ lfound[k1][found[k1]]=element;
+ found[k1]++;
+ }
+ else
+ break;
+ }
+ }
+ }
+ element=liste[element];
+ }
+ }
+ }
+}
+
+void iterate_points(long act)
+{
+ double **lfactor;
+ double *dx;
+ unsigned int i,j,l,l1;
+ long k,element,**lcount;
+
+ check_alloc(lfactor=(double**)malloc(sizeof(double*)*(maxdim-1)));
+ check_alloc(lcount=(long**)malloc(sizeof(long*)*(maxdim-1)));
+ for (i=0;i<maxdim-1;i++) {
+ check_alloc(lfactor[i]=(double*)malloc(sizeof(double)*(maxiter+1)));
+ check_alloc(lcount[i]=(long*)malloc(sizeof(long)*(maxiter+1)));
+ }
+ check_alloc(dx=(double*)malloc(sizeof(double)*(maxiter+1)));
+
+ for (i=0;i<=maxiter;i++)
+ for (j=0;j<maxdim-1;j++) {
+ lfactor[j][i]=0.0;
+ lcount[j][i]=0;
+ }
+
+ for (j=mindim-2;j<maxdim-1;j++) {
+ for (k=0;k<found[j];k++) {
+ element=lfound[j][k];
+ for (i=0;i<=maxiter;i++)
+ dx[i]=sqr(series[act+i]-series[element+i]);
+ for (l=1;l<j+2;l++) {
+ l1=l*delay;
+ for (i=0;i<=maxiter;i++)
+ dx[i] += sqr(series[act+i+l1]-series[element+l1+i]);
+ }
+ for (i=0;i<=maxiter;i++)
+ if (dx[i] > 0.0){
+ lcount[j][i]++;
+ lfactor[j][i] += dx[i];
+ }
+ }
+ }
+ for (i=mindim-2;i<maxdim-1;i++)
+ for (j=0;j<=maxiter;j++)
+ if (lcount[i][j]) {
+ count[i][j]++;
+ lyap[i][j] += log(lfactor[i][j]/lcount[i][j])/2.0;
+ }
+
+ for (i=0;i<maxdim-1;i++){
+ free(lfactor[i]);
+ free(lcount[i]);
+ }
+ free(lcount);
+ free(lfactor);
+ free(dx);
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0;
+ double eps_fak;
+ double epsilon;
+ unsigned int i,j,l;
+ 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)+6,1));
+ sprintf(outfile,"%s.lyap",infile);
+ }
+ else {
+ check_alloc(outfile=(char*)calloc(11,1));
+ sprintf(outfile,"stdin.lyap");
+ }
+ }
+ test_outfile(outfile);
+
+ series=get_series(infile,&length,exclude,column,verbosity);
+ rescale_data(series,length,&min,&max);
+
+ if (eps0set)
+ epsmin /= max;
+ if (eps1set)
+ epsmax /= max;
+
+ if (epsmin >= 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<maxdim-1;i++)
+ check_alloc(lfound[i]=(long*)malloc(sizeof(long)*(length)));
+ check_alloc(count=(long**)malloc(sizeof(long*)*(maxdim-1)));
+ for (i=0;i<maxdim-1;i++)
+ check_alloc(count[i]=(long*)malloc(sizeof(long)*(maxiter+1)));
+ check_alloc(lyap=(double**)malloc(sizeof(double*)*(maxdim-1)));
+ for (i=0;i<maxdim-1;i++)
+ check_alloc(lyap[i]=(double*)malloc(sizeof(double)*(maxiter+1)));
+
+ if (epscount == 1)
+ eps_fak=1.0;
+ else
+ eps_fak=pow(epsmax/epsmin,1.0/(double)(epscount-1));
+
+ fout=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ for (l=0;l<epscount;l++) {
+ epsilon=epsmin*pow(eps_fak,(double)l);
+ for (i=0;i<maxdim-1;i++)
+ for (j=0;j<=maxiter;j++) {
+ count[i][j]=0;
+ lyap[i][j]=0.0;
+ }
+ put_in_boxes(epsilon);
+ for (i=0;i<reference;i++) {
+ lfind_neighbors(i,epsilon);
+ iterate_points(i);
+ }
+ if (verbosity&VER_USR1)
+ fprintf(stderr,"epsilon= %e\n",epsilon*max);
+ for (i=mindim-2;i<maxdim-1;i++) {
+ fprintf(fout,"#epsilon= %e dim= %d\n",epsilon*max,i+2);
+ for (j=0;j<=maxiter;j++)
+ if (count[i][j])
+ fprintf(fout,"%d %e %ld\n",j,lyap[i][j]/count[i][j],count[i][j]);
+ fprintf(fout,"\n");
+ }
+ fflush(fout);
+ }
+ fclose(fout);
+ return 0;
+}
--- /dev/null
+/*
+ * 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: Apr 25, 2002 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <limits.h>
+#include <string.h>
+#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<NMAX;i++)
+ for (j=0;j<NMAX;j++)
+ box[i][j]= -1;
+
+ del=delay*(dim-1);
+ for (i=0;i<length-del-steps;i++) {
+ x=(int)(series[i]*epsinv)&nmax;
+ y=(int)(series[i+del]*epsinv)&nmax;
+ list[i]=box[x][y];
+ box[x][y]=i;
+ }
+}
+
+char make_iterate(long act)
+{
+ char ok=0;
+ int x,y,i,j,i1,k,del1=dim*delay;
+ long element,minelement= -1;
+ double dx,mindx=1.0;
+
+ x=(int)(series[act]*epsinv)&nmax;
+ y=(int)(series[act+delay*(dim-1)]*epsinv)&nmax;
+ for (i=x-1;i<=x+1;i++) {
+ i1=i&nmax;
+ for (j=y-1;j<=y+1;j++) {
+ element=box[i1][j&nmax];
+ while (element != -1) {
+ if (labs(act-element) > mindist) {
+ dx=0.0;
+ for (k=0;k<del1;k+=delay) {
+ dx += (series[act+k]-series[element+k])*
+ (series[act+k]-series[element+k]);
+ if (dx > 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<del1;j+=delay) {
+ dx += (series[act+j]-series[minelement+j])*
+ (series[act+j]-series[minelement+j]);
+ }
+ if (dx > 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<length;i++)
+ done[i]=0;
+
+ maxlength=length-delay*(dim-1)-steps-1-mindist;
+ alldone=0;
+ file=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ for (eps=eps0;!alldone;eps*=1.1) {
+ epsinv=1.0/eps;
+ put_in_boxes();
+ alldone=1;
+ for (n=0;n<=maxlength;n++) {
+ if (!done[n])
+ done[n]=make_iterate(n);
+ alldone &= done[n];
+ }
+ if (verbosity&VER_USR1)
+ fprintf(stderr,"epsilon: %e already found: %ld\n",eps*max,found[0]);
+ }
+ for (i=0;i<=steps;i++)
+ if (found[i])
+ fprintf(file,"%d %e\n",i,lyap[i]/found[i]/2.0);
+ fclose(file);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 Dec 4, 2005 */
+/*Changes:
+ 7/14/05: Changed borders of the sort routine to speed things up
+ 11/25/05: Show also absolute forecast errors
+ 12/04/05: Some more changes in sort
+ 12/20/05: Change in increase neighborhood size loop
+ 12/28/05: Found bug in memory allocation (index)
+*/
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <limits.h>
+#include <time.h>
+#include <string.h>
+#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<imax;i++) {
+ hf=found[i];
+ if (hf != act) {
+ maxdx=fabs(series[0][act]-series[0][hf]);
+ for (j=1;j<alldim;j++) {
+ n1=indexes[0][j];
+ del=indexes[1][j];
+ dx=fabs(series[n1][act-del]-series[n1][hf-del]);
+ if (dx > 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<MINNEIGHBORS;i++) {
+ for (j=i+1;j<imax-1;j++) {
+ if (abstand[j]<abstand[i]) {
+ dswap=abstand[i];
+ abstand[i]=abstand[j];
+ abstand[j]=dswap;
+ iswap=found[i];
+ found[i]=found[j];
+ found[j]=iswap;
+ }
+ }
+ }
+
+ if (!epsset || (abstand[MINNEIGHBORS-1] >= epsmin)) {
+ *nfound=MINNEIGHBORS;
+ *enough=1;
+ maxeps=abstand[MINNEIGHBORS-1];
+
+ return maxeps;
+ }
+
+ for (i=MINNEIGHBORS;i<imax-2;i++) {
+ for (j=i+1;j<imax-1;j++) {
+ if (abstand[j]<abstand[i]) {
+ dswap=abstand[i];
+ abstand[i]=abstand[j];
+ abstand[j]=dswap;
+ iswap=found[i];
+ found[i]=found[j];
+ found[j]=iswap;
+ }
+ }
+ if (abstand[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<DIMENSION;i++)
+ hser[i]=series[i]+act;
+
+ epsilon=epsmin/EPSSTEP;
+ do {
+ epsilon *= EPSSTEP;
+ if (epsilon > 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<nfound;i++) {
+ act=found[i];
+ mat[0][0] += 1.0;
+ for (j=0;j<alldim;j++)
+ mat[0][j+1] += series[indexes[0][j]][act-indexes[1][j]];
+ for (j=0;j<alldim;j++) {
+ hv1=series[indexes[0][j]][act-indexes[1][j]];
+ hj=j+1;
+ for (k=j;k<alldim;k++)
+ mat[hj][k+1] += series[indexes[0][k]][act-indexes[1][k]]*hv1;
+ }
+ }
+
+ for (i=0;i<=alldim;i++)
+ for (j=i;j<=alldim;j++)
+ mat[j][i]=(mat[i][j]/=(double)nfound);
+
+ imat=invert_matrix(mat,alldim+1);
+
+ for (d=0;d<DIMENSION;d++) {
+ for (i=0;i<=alldim;i++)
+ vec[i]=0.0;
+ for (i=0;i<nfound;i++) {
+ act=found[i];
+ hv=series[d][act+DELAY];
+ vec[0] += hv;
+ for (j=0;j<alldim;j++)
+ vec[j+1] += hv*series[indexes[0][j]][act-indexes[1][j]];
+ }
+ for (i=0;i<=alldim;i++)
+ vec[i] /= (double)nfound;
+
+ new_vec=0.0;
+ for (i=0;i<=alldim;i++)
+ new_vec += imat[0][i]*vec[i];
+ for (i=1;i<=alldim;i++) {
+ hi=i-1;
+ dynamics[d][hi]=0.0;
+ for (j=0;j<=alldim;j++)
+ dynamics[d][hi] += imat[i][j]*vec[j];
+ }
+ for (i=0;i<alldim;i++)
+ new_vec += dynamics[d][i]*series[indexes[0][i]][t-indexes[1][i]];
+ averr[d] += (new_vec-series[d][t+DELAY])*(new_vec-series[d][t+DELAY]);
+ }
+
+ for (i=0;i<=alldim;i++)
+ free(imat[i]);
+ free(imat);
+}
+
+void gram_schmidt(double **delta,
+ double *stretch)
+{
+ double **dnew,norm,*diff;
+ long i,j,k;
+
+ check_alloc(diff=(double*)malloc(sizeof(double)*alldim));
+ check_alloc(dnew=(double**)malloc(sizeof(double*)*alldim));
+ for (i=0;i<alldim;i++)
+ check_alloc(dnew[i]=(double*)malloc(sizeof(double)*alldim));
+
+ for (i=0;i<alldim;i++) {
+ for (j=0;j<alldim;j++)
+ diff[j]=0.0;
+ for (j=0;j<i;j++) {
+ norm=0.0;
+ for (k=0;k<alldim;k++)
+ norm += delta[i][k]*dnew[j][k];
+ for (k=0;k<alldim;k++)
+ diff[k] -= norm*dnew[j][k];
+ }
+ norm=0.0;
+ for (j=0;j<alldim;j++)
+ norm += sqr(delta[i][j]+diff[j]);
+ stretch[i]=(norm=sqrt(norm));
+ for (j=0;j<alldim;j++)
+ dnew[i][j]=(delta[i][j]+diff[j])/norm;
+ }
+ for (i=0;i<alldim;i++)
+ for (j=0;j<alldim;j++)
+ delta[i][j]=dnew[i][j];
+
+ free(diff);
+ for (i=0;i<alldim;i++)
+ free(dnew[i]);
+ free(dnew);
+}
+
+void make_iteration(double **dynamics,
+ double **delta)
+{
+ double **dnew;
+ long i,j,k;
+
+ check_alloc(dnew=(double**)malloc(sizeof(double*)*alldim));
+ for (i=0;i<alldim;i++)
+ check_alloc(dnew[i]=(double*)malloc(sizeof(double)*alldim));
+
+ for (i=0;i<alldim;i++) {
+ for (j=0;j<DIMENSION;j++) {
+ dnew[i][j]=dynamics[j][0]*delta[i][0];
+ for (k=1;k<alldim;k++)
+ dnew[i][j] += dynamics[j][k]*delta[i][k];
+ }
+ for (j=DIMENSION;j<alldim;j++)
+ dnew[i][j]=delta[i][j-1];
+ }
+
+ for (i=0;i<alldim;i++)
+ for (j=0;j<alldim;j++)
+ delta[i][j]=dnew[i][j];
+
+ for (i=0;i<alldim;i++)
+ free(dnew[i]);
+ free(dnew);
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0;
+ double **delta,**dynamics,*lfactor;
+ double *factor,dim;
+ double *hseries;
+ double *interval,*min,*av,*var,maxinterval;
+ long start,i,j;
+ time_t lasttime,newtime;
+ FILE *file=NULL;
+
+ if (scan_help(argc,argv))
+ show_options(argv[0]);
+
+ ITERATIONS=ULONG_MAX;
+
+ 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)+7,(size_t)1));
+ strcpy(outfile,infile);
+ strcat(outfile,".lyaps");
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)12,(size_t)1));
+ strcpy(outfile,"stdin.lyaps");
+ }
+ }
+ if (!stdo)
+ test_outfile(outfile);
+
+ alldim=DIMENSION*EMBED;
+
+ if (COLUMNS == NULL)
+ series=(double**)get_multi_series(infile,&LENGTH,exclude,&DIMENSION,"",
+ dimset,verbosity);
+ else
+ series=(double**)get_multi_series(infile,&LENGTH,exclude,&DIMENSION,
+ COLUMNS,dimset,verbosity);
+
+ if (MINNEIGHBORS > (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<DIMENSION;i++) {
+ averr[i]=0.0;
+ rescale_data(series[i],LENGTH,&min[i],&interval[i]);
+ if (interval[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<DIMENSION;j++) {
+ for (i=0;i<LENGTH;i++)
+ hseries[LENGTH-1-i]=series[j][i];
+ for (i=0;i<LENGTH;i++)
+ series[j][i]=hseries[i];
+ }
+ free(hseries);
+ }
+
+ if (!epsset)
+ epsmin=1./1000.;
+ else
+ epsmin /= maxinterval;
+
+ check_alloc(box=(long**)malloc(sizeof(long*)*BOX));
+ for (i=0;i<BOX;i++)
+ check_alloc(box[i]=(long*)malloc(sizeof(long)*BOX));
+
+ check_alloc(list=(long*)malloc(sizeof(long)*LENGTH));
+ check_alloc(found=(unsigned long*)malloc(sizeof(long)*LENGTH));
+
+ check_alloc(dynamics=(double**)malloc(sizeof(double*)*DIMENSION));
+ for (i=0;i<DIMENSION;i++)
+ check_alloc(dynamics[i]=(double*)malloc(sizeof(double)*alldim));
+ check_alloc(factor=(double*)malloc(sizeof(double)*alldim));
+ check_alloc(lfactor=(double*)malloc(sizeof(double)*alldim));
+ check_alloc(delta=(double**)malloc(sizeof(double*)*alldim));
+ for (i=0;i<alldim;i++)
+ check_alloc(delta[i]=(double*)malloc(sizeof(double)*alldim));
+
+ check_alloc(vec=(double*)malloc(sizeof(double)*(alldim+1)));
+ check_alloc(mat=(double**)malloc(sizeof(double*)*(alldim+1)));
+ for (i=0;i<=alldim;i++)
+ check_alloc(mat[i]=(double*)malloc(sizeof(double)*(alldim+1)));
+
+ indexes=(unsigned int**)make_multi_index(DIMENSION,EMBED,DELAY);
+
+ rnd_init(0x098342L);
+ for (i=0;i<10000;i++)
+ rnd_long();
+ for (i=0;i<alldim;i++) {
+ factor[i]=0.0;
+ for (j=0;j<alldim;j++)
+ delta[i][j]=(double)rnd_long()/(double)ULONG_MAX;
+ }
+ gram_schmidt(delta,lfactor);
+
+ start=ITERATIONS;
+ if (start>(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<start;i++) {
+ count++;
+ make_dynamics(dynamics,i);
+ make_iteration(dynamics,delta);
+ gram_schmidt(delta,lfactor);
+ for (j=0;j<alldim;j++) {
+ factor[j] += log(lfactor[j])/(double)DELAY;
+ }
+ if (((time(&newtime)-lasttime) > OUT) || (i == (start-1))) {
+ time(&lasttime);
+ if (!stdo) {
+ fprintf(file,"%ld ",count);
+ for (j=0;j<alldim;j++)
+ fprintf(file,"%e ",factor[j]/count);
+ fprintf(file,"\n");
+ fflush(file);
+ }
+ else {
+ fprintf(stdout,"%ld ",count);
+ for (j=0;j<alldim;j++)
+ fprintf(stdout,"%e ",factor[j]/count);
+ fprintf(stdout,"\n");
+ }
+ }
+ }
+
+ dim=0.0;
+ for (i=0;i<alldim;i++) {
+ dim += factor[i];
+ if (dim < 0.0)
+ break;
+ }
+ if (i < alldim)
+ dim=i+(dim-factor[i])/fabs(factor[i]);
+ else
+ dim=alldim;
+ if (!stdo) {
+ fprintf(file,"#Average relative forecast errors:= ");
+ for (i=0;i<DIMENSION;i++)
+ fprintf(file,"%e ",sqrt(averr[i]/count)/var[i]);
+ fprintf(file,"\n");
+ fprintf(file,"#Average absolute forecast errors:= ");
+ for (i=0;i<DIMENSION;i++)
+ fprintf(file,"%e ",sqrt(averr[i]/count)*interval[i]);
+ fprintf(file,"\n");
+ fprintf(file,"#Average Neighborhood Size= %e\n",aveps*maxinterval/count);
+ fprintf(file,"#Average num. of neighbors= %e\n",avneig/count);
+ fprintf(file,"#estimated KY-Dimension= %f\n",dim);
+ }
+ else {
+ fprintf(stdout,"#Average relative forecast errors:= ");
+ for (i=0;i<DIMENSION;i++)
+ fprintf(stdout,"%e ",sqrt(averr[i]/count)/var[i]);
+ fprintf(stdout,"\n");
+ fprintf(stdout,"#Average absolute forecast errors:= ");
+ for (i=0;i<DIMENSION;i++)
+ fprintf(stdout,"%e ",sqrt(averr[i]/count)*interval[i]);
+ fprintf(stdout,"\n");
+ fprintf(stdout,"#Average Neighborhood Size= %e\n",aveps*maxinterval/count);
+ fprintf(stdout,"#Average num. of neighbors= %e\n",avneig/count);
+ fprintf(stdout,"#estimated KY-Dimension= %f\n",dim);
+ }
+ if (!stdo)
+ fclose(file);
+
+ free(abstand);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 7, 2004 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include "routines/tsa.h"
+#include <math.h>
+
+#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<dim;i++) {
+ si=series[i];
+ cast=si[found[0]+STEP];
+ for (j=1;j<number;j++)
+ cast += si[found[j]+STEP];
+ cast /= (double)number;
+ error[i] += sqr(cast-series[i][act+STEP]);
+ }
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0;
+ unsigned long actfound;
+ unsigned long *hfound;
+ long pfound,i,j;
+ unsigned long clength;
+ double interval,min,maxinterval;
+ double epsilon;
+ double **hser;
+ double avfound,*hrms,*hav,sumerror=0.0;
+ 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
+
+ if (!causalset)
+ causal=STEP;
+
+ 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.lm",infile);
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)9,(size_t)1));
+ sprintf(outfile,"stdin.lm");
+ }
+ }
+ if (!stdo)
+ test_outfile(outfile);
+
+ 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);
+ maxinterval=0.0;
+ for (i=0;i<dim;i++) {
+ rescale_data(series[i],LENGTH,&min,&interval);
+ if (interval > 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<NMAX;i++)
+ check_alloc(box[i]=(long*)malloc(sizeof(long)*NMAX));
+ check_alloc(error=(double*)malloc(sizeof(double)*dim));
+ check_alloc(hrms=(double*)malloc(sizeof(double)*dim));
+ check_alloc(hav=(double*)malloc(sizeof(double)*dim));
+ check_alloc(hser=(double**)malloc(sizeof(double*)*dim));
+
+ if (eps0set)
+ EPS0 /= interval;
+ if (eps1set)
+ EPS1 /= interval;
+
+ clength=(CLENGTH <= LENGTH) ? CLENGTH-STEP : LENGTH-STEP;
+
+ if (!stdo) {
+ file=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ fprintf(file,"#1. size 2. relative forecast error 3. fraction of points\n"
+ "#4. av neighbors found 5. absolute variance of the points\n");
+ }
+ else {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Writing to stdout\n");
+ }
+
+ for (epsilon=EPS0;epsilon<EPS1*EPSF;epsilon*=EPSF) {
+ pfound=0;
+ for (i=0;i<dim;i++)
+ error[i]=hrms[i]=hav[i]=0.0;
+ avfound=0.0;
+ make_multi_box(series,box,list,LENGTH-STEP,NMAX,dim,
+ embed,delay,epsilon);
+ for (i=(embed-1)*delay;i<clength;i++) {
+ for (j=0;j<dim;j++)
+ hser[j]=series[j]+i;
+ actfound=find_multi_neighbors(series,box,list,hser,LENGTH,
+ NMAX,dim,embed,delay,epsilon,hfound);
+ actfound=exclude_interval(actfound,i-causal+1,i+causal+(embed-1)*delay-1,
+ hfound,found);
+ if (actfound > 2*(dim*embed+1)) {
+ make_fit(i,actfound);
+ pfound++;
+ avfound += (double)(actfound-1);
+ for (j=0;j<dim;j++) {
+ hrms[j] += series[j][i+STEP]*series[j][i+STEP];
+ hav[j] += series[j][i+STEP];
+ }
+ }
+ }
+ if (pfound > 1) {
+ sumerror=0.0;
+ for (j=0;j<dim;j++) {
+ hav[j] /= pfound;
+ hrms[j]=sqrt(fabs(hrms[j]/(pfound-1)-hav[j]*hav[j]*pfound/(pfound-1)));
+ error[j]=sqrt(error[j]/pfound)/hrms[j];
+ sumerror += error[j];
+ }
+ }
+ if (stdo) {
+ if (pfound > 1) {
+ fprintf(stdout,"%e %e ",epsilon*interval,sumerror/(double)dim);
+ for (j=0;j<dim;j++)
+ fprintf(stdout,"%e ",error[j]);
+ fprintf(stdout,"%e %e\n",(double)pfound/(clength-(embed-1)*delay),
+ avfound/pfound);
+ fflush(stdout);
+ }
+ }
+ else {
+ if (pfound > 1) {
+ fprintf(file,"%e %e ",epsilon*interval,sumerror/(double)dim);
+ for (j=0;j<dim;j++)
+ fprintf(file,"%e ",error[j]);
+ fprintf(file,"%e %e\n",(double)pfound/(clength-(embed-1)*delay),
+ avfound/pfound);
+ fflush(file);
+ }
+ }
+ }
+ if (!stdo)
+ fclose(file);
+
+ free(list);
+ free(hfound);
+ free(error);
+ free(hrms);
+ free(hav);
+ free(hser);
+ for (i=0;i<NMAX;i++)
+ free(box[i]);
+ free(box);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 19, 2007 */
+/* Changes:
+ 2/19/2007: Changed name and default for noise
+ 10/26/2006: Add seed option
+ */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include <time.h>
+#include <math.h>
+#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<nfound;i++) {
+ hf=found[i];
+ abstand[i]=0.0;
+ for (j=0;j<dim;j++) {
+ for (k=0;k<=hdim;k += DELAY) {
+ dx=fabs(series[j][hf-k]-cast[hdim-k][j]);
+ if (dx > abstand[i]) abstand[i]=dx;
+ }
+ }
+ }
+
+ for (i=0;i<MINN;i++)
+ for (j=i+1;j<nfound;j++)
+ if (abstand[j]<abstand[i]) {
+ dswap=abstand[i];
+ abstand[i]=abstand[j];
+ abstand[j]=dswap;
+ iswap=found[i];
+ found[i]=found[j];
+ found[j]=iswap;
+ }
+}
+
+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;i<NMAX;i++)
+ for (j=0;j<NMAX;j++)
+ box[i][j]= -1;
+
+ for (n=hdim;n<LENGTH-1;n++) {
+ i=(int)(series[0][n]*epsinv)&nmax;
+ j=(int)(series[dim1][n-hdim]*epsinv)&nmax;
+ list[n]=box[i][j];
+ box[i][j]=n;
+ }
+}
+
+unsigned int hfind_neighbors(void)
+{
+ char toolarge;
+ int i,j,i1,i2,j1,l,hc,hd,element;
+ static int hdim;
+ unsigned nfound=0;
+ double max,dx,epsinv;
+
+ hdim=(embed-1)*DELAY;
+ epsinv=1.0/epsilon;
+ i=(int)(cast[hdim][0]*epsinv)&nmax;
+ j=(int)(cast[0][dim1]*epsinv)&nmax;
+
+ for (i1=i-1;i1<=i+1;i1++) {
+ i2=i1&nmax;
+ for (j1=j-1;j1<=j+1;j1++) {
+ element=box[i2][j1&nmax];
+ while (element != -1) {
+ max=0.0;
+ toolarge=0;
+ for (l=0;l<dim*embed;l++) {
+ hc=indexes[0][l];
+ hd=indexes[1][l];
+ dx=fabs(series[hc][element-hd]-cast[hdim-hd][hc]);
+ max=(dx>max) ? 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<dim;d++) {
+ newcast[d]=0.0;
+ sd=series[d]+1;
+ for (i=0;i<number;i++)
+ newcast[d] += sd[found[i]];
+ newcast[d] /= (double)number;
+ }
+
+ if (setnoise) {
+ for (d=0;d<dim;d++)
+ newcast[d] += gaussian(var[d]*Q);
+ }
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0,done;
+ long i,j,hdim,actfound;
+ unsigned long count=1;
+ double *swap,*newcast,maxinterval,*min,*interval,dummy,epsilon0;
+ 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,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,".lzr");
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1));
+ strcpy(outfile,"stdin.lzr");
+ }
+ }
+ if (!onscreen)
+ test_outfile(outfile);
+
+ hdim=(embed-1)*DELAY+1;
+ 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);
+
+ dim1=dim-1;
+
+ check_alloc(min=(double*)malloc(sizeof(double)*dim));
+ check_alloc(interval=(double*)malloc(sizeof(double)*dim));
+ check_alloc(var=(double*)malloc(sizeof(double)*dim));
+
+ maxinterval=0.0;
+
+ for (i=0;i<dim;i++) {
+ rescale_data(series[i],LENGTH,&min[i],&interval[i]);
+ variance(series[i],LENGTH,&dummy,&var[i]);
+ if (interval[i] > maxinterval)
+ maxinterval=interval[i];
+ }
+
+ if (epsset)
+ EPS0 /= maxinterval;
+
+ check_alloc(cast=(double**)malloc(sizeof(double*)*hdim));
+ for (i=0;i<hdim;i++)
+ check_alloc(cast[i]=(double*)malloc(sizeof(double)*dim));
+ check_alloc(newcast=(double*)malloc(sizeof(double)*dim));
+ check_alloc(newav=(double*)malloc(sizeof(double)*dim));
+
+ check_alloc(list=(long*)malloc(sizeof(long)*LENGTH));
+ check_alloc(found=(long*)malloc(sizeof(long)*LENGTH));
+ check_alloc(abstand=(double*)malloc(sizeof(double)*LENGTH));
+ check_alloc(box=(long**)malloc(sizeof(long*)*NMAX));
+ for (i=0;i<NMAX;i++)
+ check_alloc(box[i]=(long*)malloc(sizeof(long)*NMAX));
+
+ check_alloc(vec=(double*)malloc(sizeof(double)*dim));
+ check_alloc(hsum=(double*)malloc(sizeof(double)*dim));
+ check_alloc(mat=(double**)malloc(sizeof(double*)*dim));
+ for (i=0;i<dim;i++) {
+ check_alloc(mat[i]=(double*)malloc(sizeof(double)*dim));
+ }
+
+ for (j=0;j<dim;j++)
+ for (i=0;i<hdim;i++)
+ cast[i][j]=series[j][LENGTH-hdim+i];
+
+ indexes=make_multi_index(dim,embed,DELAY);
+
+ if (!onscreen) {
+ 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");
+ }
+
+ rnd_init(seed);
+
+ epsilon0=EPS0/EPSF;
+
+ if (setnoise)
+ Q /= 100.0;
+
+ for (i=0;i<FLENGTH;i++) {
+ done=0;
+ if (setsort)
+ epsilon= epsilon0/((double)count*EPSF);
+ else
+ epsilon=epsilon0;
+ while (!done) {
+ epsilon*=EPSF;
+ put_in_boxes();
+ actfound=hfind_neighbors();
+ if (actfound >= MINN) {
+ if (setsort) {
+ epsilon0 += epsilon;
+ count++;
+ sort(actfound);
+ actfound=MINN;
+ }
+ make_zeroth(actfound,newcast);
+ if (onscreen) {
+ for (j=0;j<dim-1;j++)
+ printf("%e ",newcast[j]*interval[j]+min[j]);
+ printf("%e\n",newcast[dim-1]*interval[dim-1]+min[dim-1]);
+ fflush(stdout);
+ }
+ else {
+ for (j=0;j<dim-1;j++)
+ fprintf(file,"%e ",newcast[j]*interval[j]+min[j]);
+ fprintf(file,"%e\n",newcast[dim-1]*interval[dim-1]+min[dim-1]);
+ fflush(file);
+ }
+ done=1;
+ swap=cast[0];
+ for (j=0;j<hdim-1;j++)
+ cast[j]=cast[j+1];
+ cast[hdim-1]=swap;
+ for (j=0;j<dim;j++)
+ cast[hdim-1][j]=newcast[j];
+ }
+ }
+ }
+ if (!onscreen)
+ fclose(file);
+
+ if (outfile != NULL)
+ free(outfile);
+ for (i=0;i<dim;i++)
+ free(mat[i]);
+ free(mat);
+ for (i=0;i<hdim;i++)
+ free(cast[i]);
+ free(cast);
+ free(newcast);
+ free(found);
+ free(list);
+ for (i=0;i<NMAX;i++)
+ free(box[i]);
+ free(box);
+ free(vec);
+ free(newav);
+ for (i=0;i<dim;i++)
+ free(series[i]);
+ free(series);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 27, 2004 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#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 <math.h>
+#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<dim;j++) {
+ casted=0.0;
+ help=series[j]+istep;
+ for (i=0;i<number;i++)
+ casted += help[found[i]];
+ casted /= number;
+ diffs[j][act]=casted-help[act];
+ error[j][h] += sqr(casted-help[act]);
+ }
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0;
+ char alldone,*done;
+ long i,j,hi;
+ unsigned long *hfound;
+ unsigned long actfound;
+ unsigned long clength;
+ double *rms,*av,**error,**hser,*hinter;
+ FILE *file;
+
+ if (scan_help(argc,argv))
+ show_options(argv[0]);
+
+ scan_options(argc,argv);
+
+ if ((2*STEP+causal) >= ((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<dim;i++) {
+ rescale_data(series[i],LENGTH,&min,&hinter[i]);
+ variance(series[i],LENGTH,&av[i],&rms[i]);
+ interval += hinter[i];
+ }
+ interval /= (double)dim;
+
+ 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(done=(char*)malloc(sizeof(char)*LENGTH));
+ check_alloc(box=(long**)malloc(sizeof(long*)*NMAX));
+ check_alloc(error=(double**)malloc(sizeof(double*)*dim));
+ check_alloc(diffs=(double**)malloc(sizeof(double*)*dim));
+ for (j=0;j<dim;j++) {
+ check_alloc(diffs[j]=(double*)malloc(sizeof(double)*LENGTH));
+ check_alloc(error[j]=(double*)malloc(sizeof(double)*STEP));
+ for (i=0;i<STEP;i++)
+ error[j][i]=0.0;
+ }
+
+ for (i=0;i<NMAX;i++)
+ check_alloc(box[i]=(long*)malloc(sizeof(long)*NMAX));
+
+ for (i=0;i<LENGTH;i++)
+ done[i]=0;
+
+ alldone=0;
+ if (epsset)
+ EPS0 /= interval;
+
+ epsilon=EPS0/EPSF;
+
+ if (!clengthset)
+ CLENGTH=LENGTH;
+ clength=((CLENGTH*refstep+STEP) <= LENGTH) ? CLENGTH :
+ (LENGTH-(long)STEP)/refstep;
+
+ while (!alldone) {
+ alldone=1;
+ epsilon*=EPSF;
+ make_multi_box(series,box,list,LENGTH-(long)STEP,NMAX,(unsigned int)dim,
+ (unsigned int)embed,(unsigned int)DELAY,epsilon);
+ for (i=(embed-1)*DELAY;i<clength;i++)
+ if (!done[i]) {
+ hi=i*refstep;
+ for (j=0;j<dim;j++)
+ hser[j]=series[j]+hi;
+ actfound=find_multi_neighbors(series,box,list,hser,LENGTH,NMAX,
+ (unsigned int)dim,(unsigned int)embed,
+ (unsigned int)DELAY,epsilon,hfound);
+ actfound=exclude_interval(actfound,hi-(long)causal+1,
+ hi+causal+(embed-1)*DELAY-1,hfound,found);
+ if (actfound >= 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<STEP;i++) {
+ if (verbosity&VER_USR1)
+ fprintf(stdout,"# %lu ",i+1);
+ else
+ fprintf(stdout,"%lu ",i+1);
+ for (j=0;j<dim;j++)
+ fprintf(stdout,"%e ",
+ sqrt(error[j][i]/(clength-(embed-1)*DELAY))/rms[j]);
+ fprintf(stdout,"\n");
+ }
+ if (verbosity&VER_USR1) {
+ for (i=(embed-1)*DELAY;i<clength;i++) {
+ hi=i*refstep;
+ for (j=0;j<dim;j++)
+ fprintf(stdout,"%e ",diffs[j][hi]*hinter[j]);
+ fprintf(stdout,"\n");
+ }
+ }
+ }
+ else {
+ file=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ for (i=0;i<STEP;i++) {
+ if (verbosity&VER_USR1)
+ fprintf(file,"# %lu ",i+1);
+ else
+ fprintf(file,"%lu ",i+1);
+ for (j=0;j<dim;j++)
+ fprintf(file,"%e ",sqrt(error[j][i]/(clength-(embed-1)*DELAY))/rms[j]);
+ fprintf(file,"\n");
+ }
+ if (verbosity&VER_USR1) {
+ for (i=(embed-1)*DELAY;i<clength;i++) {
+ hi=i*refstep;
+ for (j=0;j<dim;j++)
+ fprintf(file,"%e ",diffs[j][hi]*hinter[j]);
+ fprintf(file,"\n");
+ }
+ }
+ fclose(file);
+ }
+
+ if (outfile != NULL)
+ free(outfile);
+ if (infile != NULL)
+ free(infile);
+ if (COLUMNS != NULL)
+ free(COLUMNS);
+ for (i=0;i<dim;i++) {
+ free(series[i]);
+ free(diffs[i]);
+ free(error[i]);
+ }
+ free(series);
+ free(diffs);
+ free(hser);
+ free(error);
+ free(av);
+ free(rms);
+ free(list);
+ free(found);
+ free(hfound);
+ free(done);
+ for (i=0;i<NMAX;i++)
+ free(box[i]);
+ free(box);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 29, 2000 */
+#include <string.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <limits.h>
+#include <time.h>
+#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;i++)
+ array[which][i] += (limit*((double)rnd_1279()/equinorm-0.5));
+}
+
+void gauss(double sigmax,unsigned int which)
+{
+ int i;
+ double glevel;
+
+ if (!absolute)
+ glevel=noiselevel*sigmax;
+ else
+ glevel=noiselevel;
+ for (i=0;i<length;i++)
+ array[which][i] += gaussian(glevel);
+}
+
+int main(int argc,char** argv)
+{
+ char stdi=0;
+ unsigned long i,j;
+ double av=0.0,*sigmax;
+ 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
+
+ if (!justcreate) {
+ infile=search_datafile(argc,argv,NULL,verbosity);
+ if (infile == NULL)
+ stdi=1;
+ }
+ else
+ stdi=1;
+
+ if (outfile == NULL) {
+ if (!stdi) {
+ check_alloc(outfile=(char*)calloc(strlen(infile)+5,(size_t)1));
+ strcpy(outfile,infile);
+ strcat(outfile,".noi");
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1));
+ strcpy(outfile,"stdin.noi");
+ }
+ }
+ if (!stout)
+ test_outfile(outfile);
+
+ if (!justcreate) {
+ if (column == NULL)
+ array=(double**)get_multi_series(infile,&length,exclude,&dim,"",dimset,
+ verbosity);
+ else
+ array=(double**)get_multi_series(infile,&length,exclude,&dim,column,
+ dimset,verbosity);
+ }
+ else {
+ check_alloc(array=(double**)malloc(sizeof(double*)*dim));
+ for (i=0;i<dim;i++) {
+ check_alloc(array[i]=(double*)malloc(sizeof(double)*length));
+ for (j=0;j<length;j++)
+ array[i][j]=0.0;
+ }
+ }
+
+ check_alloc(sigmax=(double*)malloc(sizeof(double)*dim));
+
+ if (!absolute) {
+ for (j=0;j<dim;j++)
+ variance(array[j],length,&av,&sigmax[j]);
+ }
+
+ rnd_init(iseed);
+
+ for (i=0;i<10000;i++) rnd_1279();
+
+ for (j=0;j<dim;j++) {
+ if (!cgaussian)
+ equidistri(sigmax[j],j);
+ else
+ gauss(sigmax[j],j);
+ }
+
+ if (!stout) {
+ fout=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ for (i=0;i<length;i++) {
+ for (j=0;j<dim-1;j++)
+ fprintf(fout,"%e ",array[j][i]);
+ fprintf(fout,"%e\n",array[dim-1][i]);
+ }
+ fclose(fout);
+ }
+ else {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Writing to stdout\n");
+ for (i=0;i<length;i++) {
+ for (j=0;j<dim-1;j++)
+ fprintf(stdout,"%e ",array[j][i]);
+ fprintf(stdout,"%e\n",array[dim-1][i]);
+ }
+ }
+
+ for (i=0;i<dim;i++)
+ free(array[i]);
+ free(array);
+ free(sigmax);
+ if (outfile != NULL)
+ free(outfile);
+ if (infile != NULL)
+ free(infile);
+ if (column != NULL)
+ free(column);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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:
+ Feb 19, 2007: changed meaning of -f flag and added -P flag to be
+ consistent with spectrum
+ Dec 5, 2006: Seg fault when poles > length;
+ */
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <limits.h>
+#include "routines/tsa.h"
+#include <math.h>
+
+#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<length;i++)
+ ret += series[i]*series[i];
+ ret /= length;
+
+ for (i=0;i<length;i++)
+ cov[i]=series[i];
+ series++;
+
+ for (i=0;i<poles;i++) {
+ h1=h2=0.0;
+ for (j=0;j<length-i-1;j++) {
+ h1 += cov[j]*series[j];
+ h2 += cov[j]*cov[j]+series[j]*series[j];
+ }
+ coef[i]=2.0*h1/h2;
+ ret *= (1.0-coef[i]*coef[i]);
+ for (j=0;j<i;j++)
+ coef[j]=help[j]-coef[i]*help[i-1-j];
+ if (i == hp)
+ break;
+ for (j=0;j<=i;j++)
+ help[j]=coef[j];
+ for (j=0;j<length-i-1;j++) {
+ cov[j] -= help[i]*series[j];
+ series[j]=series[j+1]-help[i]*cov[j+1];
+ }
+ }
+ free(cov);
+ free(help);
+
+ return ret;
+}
+double powcoef(double dt,double *coef)
+{
+ int i;
+ double si=0.0,sr=1.0,zr=1.0,zi=0.0,h,omdt,hr,hi;
+
+ omdt=2.0*M_PI*dt;
+ hr=cos(omdt);
+ hi=sin(omdt);
+
+ for (i=0;i<poles;i++) {
+ h=zr;
+ zr=zr*hr-zi*hi;
+ zi=h*hi+zi*hr;
+ sr -= coef[i]*zr;
+ si -= coef[i]*zi;
+ }
+ return (sr*sr+si*si);
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0;
+ double fdt,pm,pow_spec,*cof,av,var;
+ long i;
+ 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)+6,(size_t)1));
+ strcpy(outfile,infile);
+ strcat(outfile,".spec");
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)11,(size_t)1));
+ strcpy(outfile,"stdin.spec");
+ }
+ }
+ if (!stdo)
+ test_outfile(outfile);
+
+ series=(double*)get_series(infile,&length,exclude,column,verbosity);
+
+ if (length <= poles) {
+ fprintf(stderr,"\n\tNo. of poles has to be smaller then the length of the\n"
+ "\tdata set! Exiting.\n");
+ exit(MEM_SPEC_TOO_MANY_POLES);
+ }
+
+ variance(series,length,&av,&var);
+ for (i=0;i<length;i++)
+ series[i] -= av;
+
+ check_alloc(cof=(double*)malloc(sizeof(double)*poles));
+
+ pm=getcoefs(cof);
+
+ if (!stdo) {
+ fout=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ if (verbosity&VER_USR1) {
+ fprintf(fout,"#sigma^2=%e\n",pm);
+ for (i=0;i<poles;i++)
+ fprintf(fout,"#%ld %e\n",i+1,cof[i]);
+ }
+ for(i=0;i<out;i++) {
+ fdt=i/(2.0*out);
+ pow_spec=powcoef(fdt,cof);
+ fprintf(fout,"%e %e\n",fdt*samplingrate,
+ pm/pow_spec/sqrt((double)length));
+ fflush(fout);
+ }
+ fclose(fout);
+ }
+ else {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Writing to stdout\n");
+ if (verbosity&VER_USR1) {
+ fprintf(stdout,"#sigma^2=%e\n",pm);
+ for (i=0;i<poles;i++)
+ fprintf(stdout,"#%ld %e\n",i+1,cof[i]);
+ }
+ for(i=0;i<out;i++) {
+ fdt=i/(2.0*out);
+ pow_spec=powcoef(fdt,cof);
+ fprintf(stdout,"%e %e\n",fdt*samplingrate,
+ pm/pow_spec/*/sqrt((double)length)*/);
+ }
+ }
+
+ return 0;
+}
+
--- /dev/null
+/*
+ * 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 20, 2000 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <limits.h>
+#include <string.h>
+#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<partitions;i++) {
+ h1[i]=h11[i]=0;
+ for (j=0;j<partitions;j++)
+ h2[i][j]=0;
+ }
+ for (i=0;i<length;i++)
+ if (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<partitions;i++) {
+ hpi=(double)(h1[i])*norm;
+ if (hpi > 0.0) {
+ for (j=0;j<partitions;j++) {
+ hpj=(double)(h11[j])*norm;
+ if (hpj > 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<partitions;i++)
+ check_alloc(h2[i]=(long *)malloc(sizeof(long)*partitions));
+ check_alloc(array=(long *)malloc(sizeof(long)*length));
+ for (i=0;i<length;i++)
+ if (series[i] < 1.0)
+ array[i]=(long)(series[i]*(double)partitions);
+ else
+ array[i]=partitions-1;
+ free(series);
+
+ shannon=make_cond_entropy(0);
+ if (corrlength >= 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;
+}
+
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <limits.h>
+#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<alldim;i++)
+ hcor[i]=0.0;
+
+ i=(int)(series[0][n]*epsinv)&ibox;
+ j=(int)(series[comp-1][n-(embed-1)*delay]*epsinv)&ibox;
+
+ for (i1=i-1;i1<=i+1;i1++) {
+ i2=i1&ibox;
+ for (j1=j-1;j1<=j+1;j1++) {
+ element=box[i2][j1&ibox];
+ while (element != -1) {
+ for (k=0;k<alldim;k++) {
+ hcomp=indexes[0][k];
+ hdel=indexes[1][k];
+ dx=fabs(series[hcomp][n-hdel]-series[hcomp][element-hdel]);
+ if (dx > eps)
+ break;
+ }
+ if (k == alldim) {
+ nfound++;
+ for (k=0;k<alldim;k++) {
+ hcomp=indexes[0][k];
+ hdel=indexes[1][k];
+ hcor[k] += series[hcomp][element-hdel];
+ }
+ }
+ element=list[element];
+ }
+ }
+ }
+ for (k=0;k<alldim;k++) {
+ hcomp=indexes[0][k];
+ hdel=indexes[1][k];
+ corr[hcomp][n-hdel] += hcor[k]/nfound;
+ nf[hcomp][n-hdel]++;
+ }
+
+ return nfound;
+}
+
+int main(int argc,char **argv)
+{
+ char *ofname;
+ char stdi=0;
+ int iter;
+ unsigned int *nmf;
+ unsigned long n,i;
+ double dav,dvar,maxinterval,maxdvar;
+ 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,NULL,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.laz",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.laz");
+ }
+ }
+ else
+ check_alloc(ofname=(char*)calloc(strlen(outfile)+10,(size_t)1));
+
+
+ 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);
+
+ check_alloc(interval=(double*)malloc(sizeof(double)*comp));
+ check_alloc(min=(double*)malloc(sizeof(double)*comp));
+
+ maxinterval=maxdvar=0.0;
+ for (i=0;i<comp;i++) {
+ rescale_data(series[i],length,&min[i],&interval[i]);
+ if (interval[i] > 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<BOX;n++)
+ check_alloc(box[n]=(long*)malloc(sizeof(long)*BOX));
+
+ check_alloc(nf=(long**)malloc(sizeof(long*)*comp));
+ check_alloc(corr=(double**)malloc(sizeof(double*)*comp));
+ for (i=0;i<comp;i++) {
+ check_alloc(nf[i]=(long*)malloc(sizeof(long)*length));
+ check_alloc(corr[i]=(double*)malloc(sizeof(double)*length));
+ }
+
+ indexes=make_multi_index(comp,embed,delay);
+
+ if (epsset)
+ eps/=maxinterval;
+ else
+ eps=1.0/1000.;
+
+ if (epsvarset)
+ eps=epsvar*maxdvar;
+
+ for (iter=1;iter<=iterations;iter++) {
+ make_multi_box2(series,box,list,length,BOX,comp,embed,delay,eps);
+ for (n=0;n<length;n++) {
+ for (i=0;i<comp;i++) {
+ corr[i][n]=0.0;
+ nf[i][n]=0;
+ }
+ nmf[n]=1;
+ }
+
+ check_alloc(hcor=(double*)malloc(sizeof(double)*alldim));
+ for (n=(embed-1)*delay;n<length;n++)
+ nmf[n]=correct(n);
+ free(hcor);
+
+ for (n=0;n<length;n++)
+ for (i=0;i<comp;i++)
+ if (nf[i][n])
+ series[i][n]=corr[i][n]/nf[i][n];
+
+ if ((verbosity&VER_USR1) && (iter < iterations)) {
+ sprintf(ofname,"%s.%d",outfile,iter);
+ test_outfile(ofname);
+ file=fopen(ofname,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",ofname);
+ if (stdo && (iter == iterations)) {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Writing to stdout\n");
+ }
+ for (n=0;n<length;n++) {
+ if (stdo && (iter == iterations)) {
+ if (verbosity&VER_USR2) {
+ for (i=0;i<comp;i++)
+ fprintf(stdout,"%e ",series[i][n]*interval[i]+min[i]);
+ fprintf(stdout,"%u\n",nmf[n]);
+ }
+ else {
+ fprintf(stdout,"%e",series[0][n]*interval[0]+min[0]);
+ for (i=1;i<comp;i++)
+ fprintf(stdout,"%e ",series[i][n]*interval[i]+min[i]);
+ fprintf(stdout,"\n");
+ }
+ }
+ if (verbosity&VER_USR2) {
+ for (i=0;i<comp;i++)
+ fprintf(file,"%e ",series[i][n]*interval[i]+min[i]);
+ fprintf(file,"%u\n",nmf[n]);
+ }
+ else {
+ fprintf(file,"%e",series[0][n]*interval[0]+min[0]);
+ for (i=1;i<comp;i++)
+ fprintf(file," %e",series[i][n]*interval[i]+min[i]);
+ fprintf(file,"\n");
+ }
+ }
+ fclose(file);
+ }
+ if (iter == iterations) {
+ if (!stdo || (verbosity&VER_USR1)) {
+ sprintf(ofname,"%s.%d",outfile,iter);
+ test_outfile(ofname);
+ file=fopen(ofname,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",ofname);
+ if (stdo && (iter == iterations)) {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Writing to stdout\n");
+ }
+ }
+ for (n=0;n<length;n++) {
+ if (stdo) {
+ if (verbosity&VER_USR2) {
+ for (i=0;i<comp;i++)
+ fprintf(stdout,"%e ",series[i][n]*interval[i]+min[i]);
+ fprintf(stdout,"%u\n",nmf[n]);
+ }
+ else {
+ fprintf(stdout,"%e",series[0][n]*interval[0]+min[0]);
+ for (i=1;i<comp;i++)
+ fprintf(stdout," %e",series[i][n]*interval[i]+min[i]);
+ fprintf(stdout,"\n");
+ }
+ }
+ if (!stdo || (verbosity&VER_USR1)) {
+ if (verbosity&VER_USR2) {
+ for (i=0;i<comp;i++)
+ fprintf(file,"%e ",series[i][n]*interval[i]+min[i]);
+ fprintf(file,"%u\n",nmf[n]);
+ }
+ else {
+ fprintf(file,"%e",series[0][n]*interval[0]+min[0]);
+ for (i=1;i<comp;i++)
+ fprintf(file," %e",series[i][n]*interval[i]+min[i]);
+ fprintf(file,"\n");
+ }
+ }
+ }
+ if (!stdo || (verbosity&VER_USR1))
+ fclose(file);
+ }
+ }
+
+ /*cleaning up */
+ for (i=0;i<comp;i++) {
+ free(series[i]);
+ free(nf[i]);
+ free(corr[i]);
+ }
+ free(series);
+ free(nf);
+ free(corr);
+
+ for (i=0;i<2;i++)
+ free(indexes[i]);
+ free(indexes);
+
+ free(list);
+ free(nmf);
+ free(interval);
+ free(min);
+
+ for (i=0;i<BOX;i++)
+ free(box[i]);
+ free(box);
+
+ if (outfile != NULL)
+ free(outfile);
+ if (ofname != NULL)
+ free(ofname);
+ if (infile != NULL)
+ free(infile);
+ if (column != NULL)
+ free(column);
+ /* end cleaning up */
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include <ctype.h>
+#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 <math.h>
+#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<strl;i++)
+ if (str[i] == '-')
+ cm++;
+ if (cm > 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<strl;i++)
+ if (str[i] == ',')
+ cp++;
+
+ if (cp == 1) {
+ parse_minus(str,array,wopt);
+ return ;
+ }
+
+ check_alloc(hstr=(char**)malloc(sizeof(char*)*cp));
+ for (i=0;i<cp;i++)
+ check_alloc(hstr[i]=(char*)calloc(strl,1));
+
+ which=iwhich=0;
+ for (i=0;i<strl;i++) {
+ if (str[i] != ',')
+ hstr[which][iwhich++]=str[i];
+ else {
+ which++;
+ iwhich=0;
+ }
+ }
+ for (i=0;i<cp;i++) {
+ if (hstr[i][0] == '\0') {
+ fprintf(stderr,"Invalid string for the %s option! "
+ "Please consult the help-page\n",wopt);
+ exit(NSTAT_Z__INVALID_STRING_FOR_OPTION);
+ }
+ if (!isdigit(hstr[i][strlen(hstr[i])-1])) {
+ fprintf(stderr,"Invalid string for the %s option! "
+ "Please consult the help-page\n",wopt);
+ exit(NSTAT_Z__INVALID_STRING_FOR_OPTION);
+ }
+ parse_minus(hstr[i],array,wopt);
+ }
+ for (i=0;i<cp;i++)
+ free(hstr[i]);
+ free(hstr);
+}
+
+void parse_out(char *str,char *array,char *which)
+{
+ unsigned int i;
+ char test;
+
+ for (i=0;i<pieces;i++)
+ array[i]=0;
+
+ for (i=0;i<strlen(str);i++) {
+ test= (str[i] == '-') || (str[i] == ',') || isdigit(str[i]);
+ if (!test) {
+ fprintf(stderr,"Invalid string for the %s option! "
+ "Please consult the help-page\n",which);
+ exit(NSTAT_Z__INVALID_STRING_FOR_OPTION);
+ }
+ }
+ if (!isdigit(str[strlen(str)-1])) {
+ fprintf(stderr,"Invalid string for the %s option! "
+ "Please consult the help-page\n",which);
+ exit(NSTAT_Z__INVALID_STRING_FOR_OPTION);
+ }
+ parse_comma(str,array,which);
+}
+
+void parse_offset(char *str,int *iwhich,char *array,char *which)
+{
+ int i,strl;
+
+ if (str[0] != '+')
+ return;
+ strl=strlen(str);
+ for (i=1;i<strl;i++)
+ if (!isdigit(str[i])) {
+ fprintf(stderr,"Invalid string for the %s option! "
+ "Please consult the help-page\n",which);
+ exit(NSTAT_Z__INVALID_STRING_FOR_OPTION);
+ }
+ sscanf(str,"+%d",iwhich);
+ for (i=0;i<pieces;i++)
+ array[i]=0;
+}
+
+void scan_options(int n,char **in)
+{
+ unsigned int i;
+ char *out,piecesset=0;
+
+ 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,'#','u')) != NULL) {
+ sscanf(out,"%u",&pieces);
+ if (pieces < 1)
+ pieces=1;
+ piecesset=1;
+ check_alloc(firstwindow=(char*)malloc(pieces));
+ check_alloc(secondwindow=(char*)malloc(pieces));
+ for (i=0;i<pieces;i++)
+ firstwindow[i]=secondwindow[i]=1;
+ check_alloc(window=(char**)malloc(sizeof(char*)*pieces));
+ for (i=0;i<pieces;i++)
+ check_alloc(window[i]=(char*)malloc(pieces));
+ }
+ if (!piecesset) {
+ fprintf(stderr,"\tThe -# option wasn't set. Please add it!\n");
+ exit(NSTAT_Z__OPTION_NOT_SET);
+ }
+ if ((out=check_option(in,n,'1','s')) != NULL) {
+ parse_offset(out,&firstoffset,firstwindow,"-1");
+ if (firstoffset == -1)
+ parse_out(out,firstwindow,"-1");
+ }
+ if ((out=check_option(in,n,'2','s')) != NULL) {
+ parse_offset(out,&secondoffset,secondwindow,"-2");
+ if (secondoffset == -1)
+ parse_out(out,secondwindow,"-2");
+ }
+ if ((out=check_option(in,n,'n','u')) != NULL) {
+ sscanf(out,"%lu",¢er);
+ centerset=1;
+ }
+ 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) {
+ stdo=0;
+ if (strlen(out) > 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<number;i++) {
+ casted += help[found[i]];
+ }
+ casted /= number;
+
+ return sqr(casted-series2[act+STEP]);
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0;
+ char alldone,*done,sdone;
+ long i,first,second,pstart;
+ unsigned long *hfound;
+ unsigned long actfound;
+ unsigned long clength;
+ double *rms,av,error;
+ FILE *file=NULL;
+
+ if (scan_help(argc,argv))
+ show_options(argv[0]);
+
+ scan_options(argc,argv);
+
+ 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,&COLUMN,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.nsz",infile);
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1));
+ sprintf(outfile,"stdin.nsz");
+ }
+ }
+ if (!stdo)
+ test_outfile(outfile);
+
+ series=(double*)get_series(infile,&LENGTH,exclude,COLUMN,verbosity);
+
+ rescale_data(series,LENGTH,&min,&interval);
+
+ 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(done=(char*)malloc(sizeof(char)*LENGTH));
+ check_alloc(box=(long**)malloc(sizeof(long*)*NMAX));
+
+ for (i=0;i<NMAX;i++)
+ check_alloc(box[i]=(long*)malloc(sizeof(long)*NMAX));
+
+ if (epsset)
+ EPS0 /= interval;
+
+ clength=(LENGTH-(DIM-1)*DELAY)/pieces;
+ if ((clength-(DIM-1)*DELAY-STEP) < MINN) {
+ fprintf(stderr,"You chose too many pieces and will never find enough"
+ " neighbors!\n");
+ exit(NSTAT_Z__TOO_MANY_PIECES);
+ }
+ check_alloc(rms=(double*)malloc(sizeof(double)*pieces));
+ for (i=0;i<pieces;i++) {
+ series1=series+i*clength;
+ variance(series1,clength,&av,&rms[i]);
+ }
+
+ pstart=(DIM-1)*DELAY;
+ if (!centerset)
+ center=clength-STEP;
+ else
+ center=(center < (clength-STEP-pstart)) ? center : clength-STEP-pstart;
+
+ if (stdo) {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Writing to stdout\n");
+ }
+ else {
+ file=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ }
+ for (first=0;first<pieces;first++)
+ for (second=0;second<pieces;second++)
+ window[first][second]=firstwindow[first]&&secondwindow[second];
+ if (firstoffset != -1) {
+ for (second=0;second<pieces;second++)
+ for (first=second-firstoffset;first<=second+firstoffset;first++)
+ if ((first >= 0) && (first < pieces))
+ window[first][second]=secondwindow[second];
+ }
+ if (secondoffset != -1) {
+ for (first=0;first<pieces;first++)
+ for (second=first-secondoffset;second<=first+secondoffset;second++)
+ if ((second >= 0) && (second < pieces))
+ window[first][second]=firstwindow[first];
+ }
+
+ free(firstwindow);
+ free(secondwindow);
+
+ for (first=0;first<pieces;first++) {
+ sdone=0;
+ for (second=0;second<pieces;second++) {
+ if (window[first][second]) {
+ sdone=1;
+ series1=series+first*clength;
+ series2=series+second*clength;
+ for (i=0;i<LENGTH;i++)
+ done[i]=0;
+ alldone=0;
+ epsilon=EPS0/EPSF;
+ error=0.0;
+ while (!alldone) {
+ alldone=1;
+ epsilon*=EPSF;
+ make_box(series1,box,list,clength-STEP,NMAX,(unsigned int)DIM,
+ (unsigned int)DELAY,epsilon);
+ for (i=pstart;i<pstart+center;i++)
+ if (!done[i]) {
+ actfound=find_neighbors(series1,box,list,series2+i,clength,NMAX,
+ (unsigned int)DIM,(unsigned int)DELAY,
+ epsilon,hfound);
+ actfound=exclude_interval(actfound,i-causal+1,
+ i+causal+pstart-1,hfound,found);
+ if (actfound >= 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<NMAX;i++)
+ free(box[i]);
+ free(box);
+ for (i=0;i<pieces;i++)
+ free(window[i]);
+ free(window);
+ free(rms);
+ free(series);
+
+ return 0;
+}
+
--- /dev/null
+/*
+ * 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 26, 2004 */
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <math.h>
+#include <limits.h>
+#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;i++)
+ ord[i]=i;
+
+ for (i=0;i<dimemb-1;i++)
+ for (j=i+1;j<dimemb;j++)
+ if (lyap[i] < lyap[j]) {
+ max=lyap[i];
+ lyap[i]=lyap[j];
+ lyap[j]=max;
+ maxi=ord[i];
+ ord[i]=ord[j];
+ ord[j]=maxi;
+ }
+}
+
+void make_pca(double *av)
+{
+ unsigned int i,j,k,i1,i2,j1,j2,k1,k2;
+ int *ord;
+ double **mat,*matarray,*eig,*sp,hsp=0.0;
+ FILE *fout=NULL;
+
+ check_alloc(ord=(int*)malloc(sizeof(int)*dimemb));
+ check_alloc(eig=(double*)malloc(sizeof(double)*dimemb));
+ check_alloc(matarray=(double*)malloc(sizeof(double)*dimemb*dimemb));
+ check_alloc(mat=(double**)malloc(sizeof(double*)*dimemb));
+ for (i=0;i<dimemb;i++)
+ mat[i]=(double*)(matarray+i*dimemb);
+
+
+ for (i=0;i<dimemb;i++) {
+ i1=i/EMB;
+ i2=(i%EMB)*DELAY;
+ for (j=i;j<dimemb;j++) {
+ j1=j/EMB;
+ j2=(j%EMB)*DELAY;
+ mat[i][j]=0.0;
+ for (k=(EMB-1)*DELAY;k<LENGTH;k++)
+ mat[i][j] += series[i1][k-i2]*series[j1][k-j2];
+ mat[j][i]=(mat[i][j] /= (double)(LENGTH-(EMB-1)*DELAY));
+ }
+ }
+
+ eigen(mat,(unsigned long)dimemb,eig);
+ ordne(eig,ord);
+
+ if (!stout) {
+ 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 (i=0;i<dimemb;i++)
+ if (write_values) {
+ if (stout)
+ fprintf(stdout,"%d %e\n",i,eig[i]);
+ else
+ fprintf(fout,"%d %e\n",i,eig[i]);
+ }
+ else {
+ if (verbosity) {
+ if (stout)
+ fprintf(stdout,"#%d %e\n",i,eig[i]);
+ else
+ fprintf(fout,"#%d %e\n",i,eig[i]);
+ }
+ }
+ if (write_vectors) {
+ for (i=0;i<dimemb;i++) {
+ for (j=0;j<dimemb;j++) {
+ j1=ord[j];
+ if (stout)
+ fprintf(stdout,"%e ",mat[i][j1]);
+ else
+ fprintf(fout,"%e ",mat[i][j1]);
+ }
+ if (stout)
+ fprintf(stdout,"\n");
+ else
+ fprintf(fout,"\n");
+ }
+ }
+
+ if (write_comp) {
+ for (i=(EMB-1)*DELAY;i<LENGTH;i++) {
+ for (j=0;j<LDIM;j++) {
+ j1=ord[j];
+ hsp=0.0;
+ for (k=0;k<dimemb;k++) {
+ k1=k/EMB;
+ k2=(k%EMB)*DELAY;
+ hsp += mat[k][j1]*(series[k1][i-k2]+av[k1]);
+ }
+ if (stout)
+ fprintf(stdout,"%e ",hsp);
+ else
+ fprintf(fout,"%e ",hsp);
+ }
+ if (stout)
+ fprintf(stdout,"\n");
+ else
+ fprintf(fout,"\n");
+ }
+ }
+
+ if (write_proj) {
+ check_alloc(sp=(double*)malloc(sizeof(double)*LDIM));
+ for (i=0;i<(EMB-1)*DELAY;i++) {
+ for (j=0;j<DIM;j++)
+ if (stout)
+ fprintf(stdout,"%e ",series[j][i]+av[j]);
+ else
+ fprintf(fout,"%e ",series[j][i]+av[j]);
+ if (stout)
+ fprintf(stdout,"\n");
+ else
+ fprintf(fout,"\n");
+ }
+ for (i=(EMB-1)*DELAY;i<LENGTH;i++) {
+ for (j=0;j<LDIM;j++) {
+ j1=ord[j];
+ sp[j]=0.0;
+ for (k=0;k<dimemb;k++) {
+ k1=k/EMB;
+ k2=(k%EMB)*DELAY;
+ sp[j] += mat[k][j1]*series[k1][i-k2];
+ }
+ }
+ for (j=0;j<DIM;j++) {
+ hsp=0.0;
+ for (k=0;k<LDIM;k++) {
+ k1=ord[k];
+ hsp += mat[j*EMB][k1]*sp[k];
+ }
+ if (stout)
+ fprintf(stdout,"%e ",hsp+av[j]);
+ else
+ fprintf(fout,"%e ",hsp+av[j]);
+ }
+ if (stout)
+ fprintf(stdout,"\n");
+ else
+ fprintf(fout,"\n");
+ }
+ free(sp);
+ }
+
+ if (!stout)
+ fclose(fout);
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0;
+ unsigned int i,j;
+ double rms,*av;
+
+ 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,".pca");
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1));
+ strcpy(outfile,"stdin.pca");
+ }
+ }
+ if (!stout)
+ test_outfile(outfile);
+
+ 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);
+ dimemb=DIM*EMB;
+ if (!projection_set)
+ LDIM=dimemb;
+ else {
+ if (LDIM < 1) LDIM=1;
+ if (LDIM > dimemb) LDIM=dimemb;
+ }
+
+ check_alloc(av=(double*)malloc(sizeof(double)*DIM));
+ for (j=0;j<DIM;j++) {
+ av[j]=rms=0.0;
+ variance(series[j],LENGTH,&av[j],&rms);
+ for (i=0;i<LENGTH;i++)
+ series[j][i] -= av[j];
+ }
+ make_pca(av);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 <string.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <limits.h>
+#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<length-(dim-comp)*delay-1;i++) {
+ if ((series[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;
+ }
+ }
+ }
+ else {
+ for (i=(comp-1)*delay;i<length-(dim-comp)*delay-1;i++) {
+ if ((series[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<length;i++) {
+ if (series[i] < min) min=series[i];
+ if (series[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;
+}
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <limits.h>
+#include <time.h>
+#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<dim;i++) {
+ h=series[act-i*delay];
+ for (j=0;j<order[which][i];j++)
+ ret *= h;
+ }
+
+ return ret;
+}
+
+void make_fit(void)
+{
+ double **mat,*vec;
+ double h;
+ unsigned long n;
+ unsigned int i,j;
+
+ check_alloc(vec=(double*)malloc(sizeof(double)*plength));
+ check_alloc(mat=(double**)malloc(sizeof(double*)*plength));
+ for (i=0;i<plength;i++)
+ check_alloc(mat[i]=(double*)malloc(sizeof(double)*plength));
+
+ for (i=0;i<plength;i++) {
+ vec[i]=0.0;
+ for (j=0;j<plength;j++)
+ mat[i][j]=0.0;
+ }
+
+ for (n=(dim-1)*delay;n<insample-step;n++) {
+ for (i=0;i<plength;i++) {
+ vec[i] += series[n+step]*(h=polynom(n,i));
+ for (j=i;j<plength;j++)
+ mat[i][j] += polynom(n,j)*h;
+ }
+ }
+ for (i=0;i<plength;i++) {
+ vec[i] /= (insample-step-(dim-1)*delay);
+ for (j=i;j<plength;j++)
+ mat[j][i]=(mat[i][j]/=(insample-step-(dim-1)*delay));
+ }
+
+ solvele(mat,vec,plength);
+
+ for (i=0;i<plength;i++)
+ param[i]=vec[i];
+
+ free(vec);
+ for (i=0;i<plength;i++)
+ free(mat[i]);
+ free(mat);
+}
+
+double forecast_error(unsigned long i0,unsigned long i1)
+{
+ unsigned int i;
+ unsigned long n;
+ double h,error=0.0;
+
+ for (n=i0+(dim-1)*delay;n<i1-step;n++) {
+ h=0.0;
+ for (i=0;i<plength;i++)
+ h += param[i]*polynom(n,i);
+ error += (series[n+step]-h)*(series[n+step]-h);
+ }
+
+ return sqrt(error/(i1-i0-step-(dim-1)*delay));
+}
+
+int main(int argc,char **argv)
+{
+ int i,j,k,l,hl,ibest,counter;
+ char stdi=0,out_set=1,*parout;
+ double **dummy,besti,besto,withalli,withallo,errori=0.,erroro=0.;
+ double av,varianz;
+ unsigned long hlength=ULONG_MAX;
+ unsigned int **ini_params,*isout,offset;
+ FILE *file,*fpars;
+
+ 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));
+ sprintf(outfile,"%s.pbe",infile);
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1));
+ sprintf(outfile,"stdin.pbe");
+ }
+ }
+ if (!stdo)
+ test_outfile(outfile);
+
+ if (parin == NULL) {
+ check_alloc(parin=(char*)calloc((size_t)14,(size_t)1));
+ sprintf(parin,"parameter.pol");
+ }
+ file=fopen(parin,"r");
+ if (file == NULL) {
+ fprintf(stderr,"File %s does not exist. Exiting!\n",parin);
+ exit(POLYBACK__WRONG_PARAMETER_FILE);
+ }
+ fclose(file);
+
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Using %s as the parameter file\n",parin);
+ dummy=(double**)get_multi_series(parin,&hlength,0LU,&dim,"",(char)1,
+ verbosity);
+
+ offset=(unsigned int)(log((double)hlength)/log(10.0)+1.0);
+ check_alloc(parout=(char*)calloc(strlen(parin)+offset+2,(size_t)1));
+
+ check_alloc(ini_params=(unsigned int**)malloc(sizeof(int*)*hlength));
+ for (i=0;i<hlength;i++) {
+ check_alloc(ini_params[i]=(unsigned int*)malloc(sizeof(int)*dim));
+ for (j=0;j<dim;j++)
+ ini_params[i][j]=(unsigned int)dummy[j][i];
+ }
+ check_alloc(isout=(unsigned int*)malloc(sizeof(int)*hlength));
+
+ series=(double*)get_series(infile,&length,exclude,column,verbosity);
+ variance(series,length,&av,&varianz);
+
+ if (insample >= 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;i++) {
+ isout[i]=0;
+ check_alloc(order[i]=(unsigned int*)malloc(sizeof(int)*dim));
+ for (j=0;j<dim;j++)
+ order[i][j]=ini_params[i][j];
+ }
+ plength=hlength;
+
+ make_fit();
+ withalli=forecast_error(0LU,insample);
+ withallo=0.0;
+ if (out_set)
+ withallo=forecast_error(insample+1,length);
+
+ if (stdo) {
+ fprintf(stdout,"%lu %e %e\n",hlength,withalli/varianz,withallo/varianz);
+ fflush(stdout);
+ }
+ else {
+ file=fopen(outfile,"w");
+ fprintf(file,"%lu %e %e\n",hlength,withalli/varianz,withallo/varianz);
+ fflush(file);
+ }
+ free(param);
+ for (i=0;i<plength;i++)
+ free(order[i]);
+ free(order);
+
+ if ((down_to < 1) || (down_to > 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<plength;j++) {
+ check_alloc(order[j]=(unsigned int*)malloc(sizeof(int)*dim));
+ }
+ counter=plength;
+ for (j=0;j<hlength;j++)
+ if (!isout[j]) {
+ isout[j]++;
+ hl=0;
+ for (k=0;k<hlength;k++) {
+ if (!isout[k]) {
+ for (l=0;l<dim;l++)
+ order[hl][l]=ini_params[k][l];
+ hl++;
+ }
+ }
+ make_fit();
+ errori=forecast_error(0LU,insample);
+ if (out_set)
+ erroro=forecast_error(insample+1,length);
+ if (ibest == -1) {
+ besti=errori;
+ if (out_set)
+ besto=erroro;
+ ibest=j;
+ }
+ else {
+ if (out_set) {
+ if (erroro < besto) {
+ besto=erroro;
+ besti=errori;
+ ibest=j;
+ }
+ }
+ else {
+ if (errori < besti) {
+ besti=errori;
+ besto=erroro;
+ ibest=j;
+ }
+ }
+ }
+ isout[j]--;
+ }
+ isout[ibest]++;
+ free(param);
+ for (j=0;j<plength;j++)
+ free(order[j]);
+ free(order);
+ if (stdo) {
+ fprintf(stdout,"%u %e %e ",plength,besti/varianz,besto/varianz);
+ for (j=0;j<dim;j++)
+ fprintf(stdout,"%u ",ini_params[ibest][j]);
+ fprintf(stdout,"\n");
+ fflush(stdout);
+ }
+ else {
+ fprintf(file,"%u %e %e ",plength,besti/varianz,besto/varianz);
+ for (j=0;j<dim;j++)
+ fprintf(file,"%u ",ini_params[ibest][j]);
+ fprintf(file,"\n");
+ fflush(file);
+ }
+ sprintf(parout,"%s.%u",parin,plength);
+ fpars=fopen(parout,"w");
+ for (j=0;j<hlength;j++)
+ if (!isout[j]) {
+ for (k=0;k<dim;k++)
+ fprintf(fpars,"%u ",ini_params[j][k]);
+ fprintf(fpars,"\n");
+ }
+ fclose(fpars);
+ }
+
+ if (!stdo)
+ fclose(file);
+ return 0;
+}
--- /dev/null
+/*
+ * 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:
+ 6/30/2006: Norm of the errors was wrong
+*/
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <limits.h>
+#include <string.h>
+#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<pars;i++)
+ check_alloc(mat[i]=(double*)malloc(sizeof(double)*pars));
+
+ for (i=0;i<pars;i++) {
+ b[i]=0.0;
+ for (j=0;j<pars;j++)
+ mat[i][j]=0.0;
+ }
+
+ for (i=0;i<pars;i++)
+ for (j=i;j<pars;j++)
+ for (k=(DIM-1)*DELAY;k<INSAMPLE-1;k++)
+ mat[i][j] += polynom(k,DIM,coding[i],maxencode)*
+ polynom(k,DIM,coding[j],maxencode);
+ for (i=0;i<pars;i++)
+ for (j=i;j<pars;j++)
+ mat[j][i]=(mat[i][j] /= (INSAMPLE-1-(DIM-1)*DELAY));
+
+ for (i=0;i<pars;i++) {
+ for (j=(DIM-1)*DELAY;j<INSAMPLE-1;j++)
+ b[i] += series[j+1]*polynom(j,DIM,coding[i],maxencode);
+ b[i] /= (INSAMPLE-1-(DIM-1)*DELAY);
+ }
+ solvele(mat,b,pars);
+
+ for (i=0;i<pars;i++)
+ results[i]=b[i];
+
+ free(b);
+ for (i=0;i<pars;i++)
+ free(mat[i]);
+ free(mat);
+}
+
+void decode(int *out,int dim,long cur,long fac)
+{
+ int n;
+
+ n=cur/fac;
+ out[dim]=n;
+ if (dim > 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<pars;k++)
+ h += results[k]*polynom(j,DIM,coding[k],maxencode);
+ err += (series[j+1]-h)*(series[j+1]-h);
+ }
+ return err /= ((long)i1-(long)i0-(DIM-1)*DELAY);
+}
+
+void make_cast(FILE *fcast)
+{
+ int i,j,k,hi;
+ double casted;
+
+ for (i=0;i<=(DIM-1)*DELAY;i++)
+ series[i]=series[LENGTH-(DIM-1)*DELAY-1+i];
+
+ hi=(DIM-1)*DELAY;
+ for (i=1;i<=CLENGTH;i++) {
+ casted=0.0;
+ for (k=0;k<pars;k++)
+ casted += results[k]*polynom((DIM-1)*DELAY,DIM,coding[k],maxencode);
+ fprintf(fcast,"%e\n",casted*std_dev);
+ fflush(fcast);
+ for (j=0;j<(DIM-1)*DELAY;j++)
+ series[j]=series[j+1];
+ series[hi]=casted;
+ }
+ fclose(fcast);
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0;
+ int i,j,k;
+ int *opar,sumpar;
+ double in_error,out_error,av;
+ 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,".pol");
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1));
+ strcpy(outfile,"stdin.pol");
+ }
+ }
+ test_outfile(outfile);
+
+ series=(double*)get_series(infile,&LENGTH,exclude,COLUMN,verbosity);
+ variance(series,LENGTH,&av,&std_dev);
+ for (i=0;i<LENGTH;i++)
+ series[i] /= std_dev;
+
+ if (!sinsample || (INSAMPLE > LENGTH))
+ INSAMPLE=LENGTH;
+
+ maxencode=1;
+ for (i=1;i<DIM;i++)
+ maxencode *= (N+1);
+
+ for (i=1;i<=N;i++) {
+ pars += number_pars(i,1);
+ }
+ file=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ fprintf(file,"#number of free parameters= %d\n\n",pars);
+ fflush(file);
+ check_alloc(coding=(long*)malloc(sizeof(long)*pars));
+ hpar=0;
+ make_coding(N,DIM-1,1,0);
+
+ check_alloc(results=(double*)malloc(sizeof(double)*pars));
+ make_fit();
+
+ check_alloc(opar=(int*)malloc(sizeof(int)*DIM));
+ fprintf(file,"#used norm for the fit= %e\n",std_dev);
+
+ for (j=0;j<pars;j++) {
+ decode(opar,DIM-1,coding[j],maxencode);
+ fprintf(file,"#");
+ sumpar=0;
+ for (k=0;k<DIM;k++) {
+ sumpar += opar[k];
+ fprintf(file,"%d ",opar[k]);
+ }
+ fprintf(file,"%e\n",results[j]/pow(std_dev,(double)(sumpar-1)));
+ }
+ fprintf(file,"\n");
+
+ in_error=make_error((unsigned long)0,INSAMPLE);
+
+ fprintf(file,"#average insample error= %e\n",sqrt(in_error));
+
+ if (INSAMPLE < LENGTH) {
+ out_error=make_error(INSAMPLE,LENGTH);
+ fprintf(file,"#average out of sample error= %e\n",sqrt(out_error));
+ }
+
+ if (CAST)
+ make_cast(file);
+ fclose(file);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <limits.h>
+#include <time.h>
+#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<dim;i++) {
+ h=series[act-i*delay];
+ for (j=0;j<order[which][i];j++)
+ ret *= h;
+ }
+
+ return ret;
+}
+
+void make_fit(void)
+{
+ double **mat,*vec;
+ double h;
+ unsigned long n,hn;
+ unsigned int i,j;
+
+ check_alloc(vec=(double*)malloc(sizeof(double)*plength));
+ check_alloc(mat=(double**)malloc(sizeof(double*)*plength));
+ for (i=0;i<plength;i++)
+ check_alloc(mat[i]=(double*)malloc(sizeof(double)*plength));
+
+ for (i=0;i<plength;i++) {
+ vec[i]=0.0;
+ for (j=0;j<plength;j++)
+ mat[i][j]=0.0;
+ }
+
+ for (n=(dim-1)*delay;n<insample-1;n++) {
+ hn=n+1;
+ for (i=0;i<plength;i++) {
+ vec[i] += series[hn]*(h=polynom(n,i));
+ for (j=i;j<plength;j++)
+ mat[i][j] += polynom(n,j)*h;
+ }
+ }
+ for (i=0;i<plength;i++) {
+ vec[i] /= (insample-(dim-1)*delay-1);
+ for (j=i;j<plength;j++)
+ mat[j][i]=(mat[i][j]/=(insample-(dim-1)*delay)-1);
+ }
+
+ solvele(mat,vec,plength);
+
+ for (i=0;i<plength;i++)
+ param[i]=vec[i];
+
+ free(vec);
+ for (i=0;i<plength;i++)
+ free(mat[i]);
+ free(mat);
+}
+
+double forecast_error(unsigned long i0,unsigned long i1)
+{
+ unsigned int i;
+ unsigned long n;
+ double h,error=0.0;
+
+ for (n=i0+(dim-1)*delay;n<i1-1;n++) {
+ h=0.0;
+ for (i=0;i<plength;i++)
+ h += param[i]*polynom(n,i);
+ error += (series[n+1]-h)*(series[n+1]-h);
+ }
+
+ return sqrt(error/(i1-i0-(dim-1)*delay-1));
+}
+
+void make_cast(FILE *fcast)
+{
+ int i,j,hi;
+ unsigned int k;
+ double casted;
+
+ for (i=0;i<=(dim-1)*delay;i++)
+ series[i]=series[length-(dim-1)*delay+i-1];
+
+ hi=(dim-1)*delay;
+ for (i=1;i<=step;i++) {
+ casted=0.0;
+ for (k=0;k<plength;k++)
+ casted += param[k]*polynom((unsigned long)((dim-1)*delay),k);
+ if (!stdo) {
+ fprintf(fcast,"%e\n",casted);
+ fflush(fcast);
+ }
+ else {
+ fprintf(stdout,"%e\n",casted);
+ fflush(stdout);
+ }
+ for (j=0;j<(dim-1)*delay;j++)
+ series[j]=series[j+1];
+ series[hi]=casted;
+ }
+}
+
+int main(int argc,char **argv)
+{
+ int i,j;
+ char stdi=0,oose=1;
+ double **dummy,withalli,withallo;
+ double av,varianz;
+ 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));
+ sprintf(outfile,"%s.pbf",infile);
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1));
+ sprintf(outfile,"stdin.pbf");
+ }
+ }
+ if (!stdo)
+ test_outfile(outfile);
+
+ if (parin == NULL) {
+ check_alloc(parin=(char*)calloc((size_t)14,(size_t)1));
+ sprintf(parin,"parameter.pol");
+ }
+ file=fopen(parin,"r");
+ if (file == NULL) {
+ fprintf(stderr,"File %s does not exist. Exiting!\n",parin);
+ exit(POLYNOMP__WRONG_PARAMETER_FILE);
+ }
+ fclose(file);
+
+ dummy=(double**)get_multi_series(parin,&plength,0LU,
+ &dim,"",(char)"1",verbosity);
+
+ check_alloc(order=(unsigned int**)malloc(sizeof(int*)*plength));
+ for (i=0;i<plength;i++) {
+ check_alloc(order[i]=(unsigned int*)malloc(sizeof(int)*dim));
+ for (j=0;j<dim;j++)
+ order[i][j]=(unsigned int)dummy[j][i];
+ }
+
+ series=(double*)get_series(infile,&length,exclude,column,verbosity);
+ variance(series,length,&av,&varianz);
+
+ if (insample >= 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<plength;i++) {
+ fprintf(stdout,"# ");
+ for (j=0;j<dim;j++)
+ fprintf(stdout,"%u ",order[i][j]);
+ fprintf(stdout,"%e\n",param[i]);
+ }
+ fflush(stdout);
+ }
+ else {
+ file=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ fprintf(file,"#FCE: %e %e\n",withalli/varianz,withallo/varianz);
+ for (i=0;i<plength;i++) {
+ fprintf(file,"# ");
+ for (j=0;j<dim;j++)
+ fprintf(file,"%u ",order[i][j]);
+ fprintf(file,"%e\n",param[i]);
+ }
+ fflush(file);
+ }
+
+ make_cast(file);
+
+ if (!stdo)
+ fclose(file);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#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<dim;j++)
+ fprintf(file,"%u ",par[j]);
+ fprintf(file,"\n");
+ }
+ else
+ make_parameter(par,d-1,sum);
+ }
+ sum -= i;
+ }
+ par[d]=0;
+}
+
+int main(int argc,char **argv)
+{
+ unsigned int i,*params;
+
+ 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
+
+
+ if (outfile == NULL) {
+ check_alloc(outfile=(char*)calloc((size_t)14,(size_t)1));
+ sprintf(outfile,"parameter.pol");
+ }
+ test_outfile(outfile);
+
+ check_alloc(params=(unsigned int*)malloc(sizeof(unsigned int)*dim));
+ for (i=0;i<dim;i++)
+ params[i]=0;
+
+ file=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ make_parameter(params,dim-1,0);
+ fclose(file);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 11, 2002 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include "routines/tsa.h"
+#include <math.h>
+
+#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<CENTER;i++)
+ for (j=0;j<CENTER;j++)
+ if (i != j)
+ for (k=0;k<DIM;k++)
+ dist += sqr(center[i][k]-center[j][k]);
+
+ return sqrt(dist/(CENTER-1)/CENTER/DIM);
+}
+
+double rbf(double *act,double *cen)
+{
+ static double denum;
+ double r=0;
+ int i;
+
+ denum=2.0*varianz*varianz;
+
+ for (i=0;i<DIM;i++)
+ r += sqr(*(act-i*DELAY)-cen[i]);
+
+ return exp(-r/denum);
+}
+
+void drift(void)
+{
+ double *force,h,h1,step=1e-2,step1;
+ int i,j,k,l,d2=DIM;
+
+ check_alloc(force=(double*)malloc(sizeof(double)*d2));
+ for (l=0;l<20;l++) {
+ for (i=0;i<CENTER;i++) {
+ for (j=0;j<d2;j++) {
+ force[j]=0.0;
+ for (k=0;k<CENTER;k++) {
+ if (k != i) {
+ h=center[i][j]-center[k][j];
+ force[j] += h/sqr(h)/fabs(h);
+ }
+ }
+ }
+ h=0.0;
+ for (j=0;j<d2;j++)
+ h += sqr(force[j]);
+ step1=step/sqrt(h);
+ for (j=0;j<d2;j++) {
+ h1 = step1*force[j];
+ if (((center[i][j]+h1) > -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<INSAMPLE-STEP;n++) {
+ nst=n+STEP;
+ for (i=0;i<CENTER;i++)
+ hcen[i]=rbf(&series[n],center[i]);
+ coefs[0] += series[nst];
+ mat[0][0] += 1.0;
+ for (i=1;i<=CENTER;i++)
+ mat[i][0] += hcen[i-1];
+ for (i=1;i<=CENTER;i++) {
+ coefs[i] += series[nst]*(h=hcen[i-1]);
+ for (j=1;j<=i;j++)
+ mat[i][j] += h*hcen[j-1];
+ }
+ }
+
+ h=(double)(INSAMPLE-STEP-(DIM-1)*DELAY);
+ for (i=0;i<=CENTER;i++) {
+ coefs[i] /= h;
+ for (j=0;j<=i;j++) {
+ mat[i][j] /= h;
+ mat[j][i]=mat[i][j];
+ }
+ }
+
+ solvele(mat,coefs,(unsigned int)(CENTER+1));
+
+ for (i=0;i<=CENTER;i++)
+ free(mat[i]);
+ free(mat);
+ free(hcen);
+}
+
+double forecast_error(unsigned long i0,unsigned long i1)
+{
+ int i,n;
+ double h,error=0.0;
+
+ for (n=i0+(DIM-1)*DELAY;n<i1-STEP;n++) {
+ h=coefs[0];
+ for (i=1;i<=CENTER;i++)
+ h += coefs[i]*rbf(&series[n],center[i-1]);
+ error += (series[n+STEP]-h)*(series[n+STEP]-h);
+ }
+
+ return sqrt(error/(i1-i0-STEP-(DIM-1)*DELAY));
+}
+
+void make_cast(FILE *out)
+{
+ double *cast,new_el;
+ int i,n,dim;
+
+ dim=(DIM-1)*DELAY;
+ check_alloc(cast=(double*)malloc(sizeof(double)*(dim+1)));
+ for (i=0;i<=dim;i++)
+ cast[i]=series[LENGTH-1-dim+i];
+
+ for (n=0;n<CLENGTH;n++) {
+ new_el=coefs[0];
+ for (i=1;i<=CENTER;i++)
+ new_el += coefs[i]*rbf(&cast[dim],center[i-1]);
+ fprintf(out,"%e\n",new_el*interval+min);
+ for (i=0;i<dim;i++)
+ cast[i]=cast[i+1];
+ cast[dim]=new_el;
+ }
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0;
+ int i,j,cstep;
+ double sigma,av;
+ 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)+5,(size_t)1));
+ strcpy(outfile,infile);
+ strcat(outfile,".rbf");
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1));
+ strcpy(outfile,"stdin.rbf");
+ }
+ }
+ if (!stdo)
+ test_outfile(outfile);
+
+ series=(double*)get_series(infile,&LENGTH,exclude,COLUMN,verbosity);
+ rescale_data(series,LENGTH,&min,&interval);
+ variance(series,LENGTH,&av,&varianz);
+
+ if (INSAMPLE > 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;i<CENTER;i++)
+ check_alloc(center[i]=(double*)malloc(sizeof(double)*DIM));
+
+ cstep=LENGTH-1-(DIM-1)*DELAY;
+ for (i=0;i<CENTER;i++)
+ for (j=0;j<DIM;j++)
+ center[i][j]=series[(DIM-1)*DELAY-j*DELAY+(i*cstep)/(CENTER-1)];
+
+ if (setdrift)
+ drift();
+ varianz=avdistance();
+ make_fit();
+
+ if (!stdo) {
+ file=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ fprintf(file,"#Center points used:\n");
+ for (i=0;i<CENTER;i++) {
+ fprintf(file,"#");
+ for (j=0;j<DIM;j++)
+ fprintf(file," %e",center[i][j]*interval+min);
+ fprintf(file,"\n");
+ }
+ fprintf(file,"#variance= %e\n",varianz*interval);
+ fprintf(file,"#Coefficients:\n");
+ fprintf(file,"#%e\n",coefs[0]*interval+min);
+ for (i=1;i<=CENTER;i++)
+ fprintf(file,"#%e\n",coefs[i]*interval);
+ }
+ else {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Writing to stdout\n");
+ fprintf(stdout,"#Center points used:\n");
+ for (i=0;i<CENTER;i++) {
+ fprintf(stdout,"#");
+ for (j=0;j<DIM;j++)
+ fprintf(stdout," %e",center[i][j]*interval+min);
+ fprintf(stdout,"\n");
+ }
+ fprintf(stdout,"#variance= %e\n",varianz*interval);
+ fprintf(stdout,"#Coefficients:\n");
+ fprintf(stdout,"#%e\n",coefs[0]*interval+min);
+ for (i=1;i<=CENTER;i++)
+ fprintf(stdout,"#%e\n",coefs[i]*interval);
+ }
+ av=sigma=0.0;
+ for (i=0;i<INSAMPLE;i++) {
+ av += series[i];
+ sigma += series[i]*series[i];
+ }
+ av /= INSAMPLE;
+ sigma=sqrt(fabs(sigma/INSAMPLE-av*av));
+ if (!stdo)
+ fprintf(file,"#insample error= %e\n",forecast_error(0LU,INSAMPLE)/sigma);
+ else
+ fprintf(stdout,"#insample error= %e\n",forecast_error(0LU,INSAMPLE)/sigma);
+
+ if (INSAMPLE < LENGTH) {
+ av=sigma=0.0;
+ for (i=INSAMPLE;i<LENGTH;i++) {
+ av += series[i];
+ sigma += series[i]*series[i];
+ }
+ av /= (LENGTH-INSAMPLE);
+ sigma=sqrt(fabs(sigma/(LENGTH-INSAMPLE)-av*av));
+ if (!stdout)
+ fprintf(file,"#out of sample error= %e\n",
+ forecast_error(INSAMPLE,LENGTH)/sigma);
+ else
+ fprintf(stdout,"#out of sample error= %e\n",
+ forecast_error(INSAMPLE,LENGTH)/sigma);
+ }
+
+ if (MAKECAST) {
+ if (!stdo)
+ make_cast(file);
+ else
+ make_cast(stdout);
+ }
+
+ if (!stdo)
+ fclose(file);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 16, 2004 */
+/* Sep 16, 2004: Change of index in output. before 0->N-1 now 1->N
+ */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <limits.h>
+#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<length;n++) {
+ i=(int)(series[0][n]*epsinv)&ibox;
+ j=(int)(series[dim-1][n]*epsinv)&ibox;
+ for (i1=i-1;i1<=i+1;i1++) {
+ i2=i1&ibox;
+ for (j1=j-1;j1<=j+1;j1++) {
+ element=box[i2][j1&ibox];
+ while (element > n) {
+ toolarge=0;
+ for (ke=0;ke<embed;ke++) {
+ ked=ke*delay;
+ for (kd=0;kd<dim;kd++) {
+ dx=fabs(series[kd][n-ked]-series[kd][element-ked]);
+ if (dx >= 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<dim;i++) {
+ rescale_data(series[i],length,&min,&max);
+ if (max > 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<BOX;i++)
+ check_alloc(box[i]=(long*)malloc(sizeof(long)*BOX));
+
+ make_multi_box(series,box,list,length,BOX,dim,embed,delay,eps);
+ lfind_neighbors();
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 11, 2002 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include <math.h>
+#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<horder;i++)
+ check_alloc(mat[i]=(double*)malloc(sizeof(double)*horder));
+ check_alloc(vec=(double*)malloc(sizeof(double)*horder));
+ check_alloc(coef=(double*)malloc(sizeof(double)*horder));
+
+ for (i=0;i<horder;i++)
+ for (j=0;j<horder;j++)
+ mat[i][j]=pow((double)(horder2+i),(double)j);
+
+ imat=invert_matrix(mat,(unsigned int)horder);
+
+ 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");
+ }
+
+ time=(horder+1)/2.;
+ itime_old= -1;
+ while (time < (double)(length-horder/2)) {
+ itime=(int)time+horder2;
+ if (itime != itime_old) {
+ for (i=0;i<horder;i++)
+ vec[i]=series[i+itime];
+ for (i=0;i<horder;i++) {
+ coef[i]=0.0;
+ for (j=0;j<horder;j++)
+ coef[i] += imat[i][j]*vec[j];
+ }
+ }
+ itime_old=itime;
+ htime=time-itime+horder2;
+ new_el=coef[0];
+ for (i=1;i<horder;i++)
+ new_el += coef[i]*pow(htime,(double)i);
+ if (stdo)
+ fprintf(stdout,"%e\n",new_el);
+ else
+ fprintf(file,"%e\n",new_el);
+ time += sampletime;
+ }
+ if (!stdo)
+ fclose(file);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 23, 2000 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include <math.h>
+#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;n<dim;n++) {
+ variance(series[n],length,&av,&varianz);
+
+ if (set_av)
+ for (i=0;i<length;i++)
+ series[n][i] -= av;
+
+ if (set_var)
+ for (i=0;i<length;i++)
+ series[n][i] /= varianz;
+
+ if (!set_var && !set_av) {
+ rescale_data(series[n],length,&min,&max);
+ for (i=0;i<length;i++)
+ series[n][i]=series[n][i]*(xmax-xmin)+xmin;
+ }
+ }
+
+ if (stdo) {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Writing to stdout\n");
+ for (i=0;i<length;i++) {
+ fprintf(stdout,"%e",series[0][i]);
+ for (n=1;n<dim;n++)
+ fprintf(stdout," %e",series[n][i]);
+ fprintf(stdout,"\n");
+ }
+ }
+ else {
+ file=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ for (i=0;i<length;i++) {
+ fprintf(file,"%e",series[0][i]);
+ for (n=1;n<dim;n++)
+ fprintf(file," %e",series[n][i]);
+ fprintf(file,"\n");
+ }
+ fclose(file);
+ }
+
+ return 0;
+}
--- /dev/null
+SHELL = /bin/sh
+
+AR = @AR@
+ARFLAGS = @ARFLAGS@
+CC = @CC@
+CFLAGS = @CFLAGS@
+RANLIB = @RANLIB@
+
+ALL = get_series.o rescale_data.o make_box.o\
+ find_neighbors.o scan_help.o variance.o get_multi_series.o\
+ search_datafile.o check_option.o solvele.o rand.o eigen.o\
+ test_outfile.o invert_matrix.o exclude_interval.o make_multi_box.o\
+ find_multi_neighbors.o check_alloc.o myfgets.o what_i_do.o\
+ make_multi_index.o make_multi_box2.o rand_arb_dist.o
+
+libddtsa.a: $(ALL)
+ $(AR) $(ARFLAGS) libddtsa.a $?
+ $(RANLIB) libddtsa.a
+
+clean:
+ @rm -f *.a *.o *~ #*#
--- /dev/null
+/*
+ * 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 <stdlib.h>
+#include <stdio.h>
+#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);
+ }
+}
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+#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<n;i++)
+ if (!isdigit((unsigned int)tocheck[i]))
+ ok=0;
+
+ if (!ok) {
+ fprintf(stderr,"Wrong type of parameter for flag -%c. Has to be an "
+ "unsigned integer\n",which);
+ exit(CHECK_OPTION_NOT_UNSIGNED);
+ }
+}
+
+void check_integer(char *tocheck,int which)
+{
+ int i,n;
+ char ok=1;
+
+ n=strlen(tocheck);
+ ok=(tocheck[0] == '-') || isdigit((unsigned int)tocheck[0]);
+ if (ok)
+ for (i=1;i<n;i++)
+ if (!isdigit((unsigned int)tocheck[i]))
+ ok=0;
+
+ if (!ok) {
+ fprintf(stderr,"Wrong type of parameter for flag -%c. Has to be an "
+ "integer\n",which);
+ exit(CHECK_OPTION_NOT_INTEGER);
+ }
+}
+
+void check_float(char *tocheck,int which)
+{
+ double dummy;
+ int found;
+ char *rest;
+
+ check_alloc(rest=(char*)calloc(strlen(tocheck)+1,(size_t)1));
+ found=sscanf(tocheck,"%lf%s",&dummy,rest);
+ if (found != 1) {
+ fprintf(stderr,"Wrong type of parameter for flag -%c. Has to be a "
+ "float\n",which);
+ exit(CHECK_OPTION_NOT_FLOAT);
+ }
+ free(rest);
+}
+
+void check_two(char *tocheck,int which)
+{
+ int i,j;
+ unsigned int len;
+
+ len=(unsigned int)strlen(tocheck);
+ for (i=0;i<len;i++)
+ if (tocheck[i] == ',')
+ break;
+ if (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<i;j++)
+ if (!isdigit((unsigned int)tocheck[j])) {
+ fprintf(stderr,"Wrong type of parameter for flag -%c. Has to be"
+ " unsigned,unsigned\n",which);
+ exit(CHECK_OPTION_NOT_TWO);
+ }
+ for (j=i+1;j<len;j++)
+ if (!isdigit((unsigned int)tocheck[j])) {
+ fprintf(stderr,"Wrong type of parameter for flag -%c. Has to be"
+ " unsigned,unsigned\n",which);
+ exit(CHECK_OPTION_NOT_TWO);
+ }
+}
+
+void check_three(char *tocheck,int which)
+{
+ int i,j,k;
+ unsigned int len;
+
+ len=(unsigned int)strlen(tocheck);
+ for (i=0;i<len;i++)
+ if (tocheck[i] == ',')
+ break;
+
+ if (i >= (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;j++)
+ if (tocheck[j] == ',')
+ break;
+
+ if (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<i;k++)
+ if (!isdigit((unsigned int)tocheck[k])) {
+ fprintf(stderr,"Wrong type of parameter for flag -%c. Has to be"
+ " unsigned,unsigned,unsigned\n",which);
+ exit(CHECK_OPTION_NOT_THREE);
+ }
+ for (k=i+1;k<j;k++)
+ if (!isdigit((unsigned int)tocheck[k])) {
+ fprintf(stderr,"Wrong type of parameter for flag -%c. Has to be"
+ " unsigned,unsigned,unsigned\n",which);
+ exit(CHECK_OPTION_NOT_THREE);
+ }
+ for (k=j+1;k<len;k++)
+ if (!isdigit((unsigned int)tocheck[k])) {
+ fprintf(stderr,"Wrong type of parameter for flag -%c. Has to be"
+ " unsigned,unsigned,unsigned\n",which);
+ exit(CHECK_OPTION_NOT_THREE);
+ }
+}
+
+char check_optional(char *tocheck,int which)
+{
+ if (tocheck[0] == '-') {
+ fprintf(stderr,"If you want to give the -%c flag a parameter starting"
+ " with a - don't put a space. Ignoring it.\n",which);
+ return 0;
+ }
+ return 1;
+}
+
+char* check_option(char **in,int n,int which,int type)
+{
+ char test,*ret=NULL,wasfound=0,ok=1;
+ int i;
+
+ for (i=1;i<n;i++) {
+ if (in[i] != NULL) {
+ test= (in[i][0] == '-') && (in[i][1] == which);
+ if (test) {
+ wasfound=1;
+ if (type != 'n') {
+ if (strlen(in[i]) > 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;
+}
--- /dev/null
+--- 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]);
--- /dev/null
+#include <math.h>
+#include <stdlib.h>
+#include <stdio.h>
+#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<nm;i++)
+ for (j=0;j<nm;j++)
+ mat[i][j]=trans[i+nm*j];
+
+ free(trans);
+ free(off);
+}
--- /dev/null
+/*
+ * 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: Apr 17, 1999 */
+#include <stdio.h>
+#include <stdlib.h>
+#ifndef _MATH_H
+#include <math.h>
+#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<n;i++) {
+ help=hf[i];
+ if ((help < ex0) || (help > ex1))
+ found[lf++]=help;
+ }
+ return lf;
+}
--- /dev/null
+/*
+ * 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 <math.h>
+
+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<emb;k++) {
+ k1= -k*(int)del;
+ for (li=0;li<dim;li++) {
+ dx=fabs(x[li][k1]-s[li][element+k1]);
+ if (dx > eps)
+ break;
+ }
+ if (dx > eps)
+ break;
+ }
+ if (dx <= eps)
+ flist[nf++]=element;
+ element=list[element];
+ }
+ }
+ }
+ return nf;
+}
--- /dev/null
+/*
+ * 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 <math.h>
+
+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<dim;k++) {
+ k1= -k*(int)del;
+ dx=fabs(x[k1]-s[element+k1]);
+ if (dx > eps)
+ break;
+ }
+ if (k == dim)
+ flist[nf++]=element;
+ element=list[element];
+ }
+ }
+ }
+ return nf;
+}
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+#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<strlen(which)-1;i++) {
+ if (!isdigit((unsigned int)which[i]) && (which[i] != ',')) {
+ fprintf(stderr,"Wrong format in the column string."
+ " Has to be num,num,num,...,num\n");
+ exit(GET_MULTI_SERIES_WRONG_TYPE_OF_C);
+ }
+ if (which[i] == ',') {
+ colcount++;
+ which[i]=' ';
+ }
+ }
+ if (!isdigit((unsigned int)which[strlen(which)-1])) {
+ fprintf(stderr,"Wrong format in the column string."
+ " Has to be num,num,num,...,num\n");
+ exit(GET_MULTI_SERIES_WRONG_TYPE_OF_C);
+ }
+ }
+ if (!colfix && (*col < colcount))
+ *col=colcount;
+
+ check_alloc(input=(char*)calloc((size_t)input_size,(size_t)1));
+ check_alloc(hcol=(unsigned int*)malloc(sizeof(unsigned int)* *col));
+ while ((int)(*which) && isspace((unsigned int)(*which)))
+ which++;
+ if (*which)
+ for (i=0;i< *col-1;i++) {
+ sscanf(which,"%u",&hcol[i]);
+ if (hcol[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<hcol[i];j++)
+ strcat(format[i],"%*lf");
+ strcat(format[i],"%lf");
+ }
+ free(hcol);
+
+ check_alloc(x=(double**)malloc(sizeof(double*)* *col));
+ for (i=0;i< *col;i++)
+ check_alloc(x[i]=(double*)malloc(sizeof(double)*max_size));
+ hl= *l;
+
+ count=0;
+ allcount=0;
+ if (name == NULL) {
+ for (i=0;i<ex;i++)
+ if ((input=myfgets(input,&input_size,stdin,verbosity)) == NULL)
+ break;
+ while ((count < hl) &&
+ ((input=myfgets(input,&input_size,stdin,verbosity)) != NULL)) {
+ if (count == max_size) {
+ max_size += SIZE_STEP;
+ for (i=0;i< *col;i++)
+ check_alloc(x[i]=(double*)realloc(x[i],sizeof(double)*max_size));
+ }
+ allcount++;
+ for (i=0;i< *col;i++)
+ if (sscanf(input,format[i],&x[i][count]) != 1) {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Line %lu ignored: %s",allcount,input);
+ break;
+ }
+ if (i == *col)
+ count++;
+ }
+ }
+ else {
+ fin=fopen(name,"r");
+ for (i=0;i<ex;i++)
+ if ((input=myfgets(input,&input_size,fin,verbosity)) == NULL)
+ break;
+ while ((count < hl) &&
+ ((input=myfgets(input,&input_size,fin,verbosity)) != NULL)) {
+ if (count == max_size) {
+ max_size += SIZE_STEP;
+ for (i=0;i< *col;i++)
+ check_alloc(x[i]=(double*)realloc(x[i],sizeof(double)*max_size));
+ }
+ allcount++;
+ for (i=0;i< *col;i++)
+ if (sscanf(input,format[i],&x[i][count]) != 1) {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Line %lu ignored: %s",allcount,input);
+ break;
+ }
+ if ((count == 0) && (i == *col) && (verbosity&VER_FIRST_LINE)) {
+ fprintf(stderr,"get_multi_series: first data item(s) used:\n");
+ for (i=0;i< *col;i++)
+ fprintf(stderr,"%lf ",x[i][0]);
+ fprintf(stderr,"\n");
+ }
+ if (i == *col)
+ count++;
+ }
+ fclose(fin);
+ }
+
+ for (i=0;i< *col;i++)
+ free(format[i]);
+ free(format);
+ free(input);
+
+ *l = count;
+ if (*l == 0) {
+ fprintf(stderr,"0 lines read. It makes no sense to continue. Exiting!\n");
+ exit(GET_MULTI_SERIES_NO_LINES);
+ }
+ else {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Use %lu lines.\n",*l);
+ }
+
+ if (max_size > count)
+ for (i=0;i< *col;i++)
+ check_alloc(x[i]=(double*)realloc(x[i],sizeof(double)*count));
+
+ return x;
+}
+#undef SIZE_STEP
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#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<col;i++)
+ strcat(format,"%*lf");
+ strcat(format,"%lf");
+
+ check_alloc(x=(double*)malloc(sizeof(double)*max_size));
+ hl= *l;
+
+ count=0;
+ allcount=0;
+ if (name == NULL) {
+ for (i=0;i<ex;i++)
+ if ((input=myfgets(input,&input_size,stdin,verbosity)) == NULL)
+ break;
+ while ((count < hl) &&
+ ((input=myfgets(input,&input_size,stdin,verbosity)) != NULL)) {
+ if (count == max_size) {
+ max_size += SIZE_STEP;
+ check_alloc(x=(double*)realloc(x,sizeof(double)*max_size));
+ }
+ allcount++;
+ if (sscanf(input,format,&x[count]) != 1) {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Line %lu ignored: %s",allcount,input);
+ }
+ else
+ count++;
+ if ((verbosity&VER_FIRST_LINE) && (count == 0))
+ fprintf(stderr,"get_series: first data item used:\n%lf\n",x[0]);
+ }
+ }
+ else {
+ fin=fopen(name,"r");
+ for (i=0;i<ex;i++)
+ if ((input=myfgets(input,&input_size,fin,verbosity)) == NULL)
+ break;
+ while ((count < hl) &&
+ ((input=myfgets(input,&input_size,fin,verbosity)) != NULL)) {
+ if (count == max_size) {
+ max_size += SIZE_STEP;
+ check_alloc(x=(double*)realloc(x,sizeof(double)*max_size));
+ }
+ allcount++;
+ if (sscanf(input,format,&x[count]) != 1) {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Line %lu ignored: %s",allcount,input);
+ }
+ else
+ count++;
+ }
+ fclose(fin);
+ }
+ free(input);
+
+ *l = count;
+ if (*l == 0) {
+ fprintf(stderr,"0 lines read. It makes no sense to continue. Exiting!\n");
+ exit(GET_SERIES_NO_LINES);
+ }
+ else {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Use %lu lines.\n",*l);
+ }
+ if (max_size > count)
+ check_alloc(x=(double*)realloc(x,sizeof(double)*count));
+
+ return x;
+}
+#undef SIZE_STEP
--- /dev/null
+/*
+ * 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 <stdlib.h>
+#include <stdio.h>
+#include <math.h>
+
+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<size;i++) {
+ check_alloc(hmat[i]=(double*)malloc(sizeof(double)*size));
+ }
+
+ check_alloc(imat=(double**)malloc(sizeof(double*)*size));
+ for (i=0;i<size;i++) {
+ check_alloc(imat[i]=(double*)malloc(sizeof(double)*size));
+ }
+
+ check_alloc(vec=(double*)malloc(sizeof(double)*size));
+
+ for (i=0;i<size;i++) {
+ for (j=0;j<size;j++) {
+ vec[j]=(i==j)?1.0:0.0;
+ for (k=0;k<size;k++)
+ hmat[j][k]=mat[j][k];
+ }
+ solvele(hmat,vec,size);
+ for (j=0;j<size;j++)
+ imat[j][i]=vec[j];
+ }
+
+ free(vec);
+ for (i=0;i<size;i++)
+ free(hmat[i]);
+ free(hmat);
+
+ return imat;
+}
--- /dev/null
+/*
+ * 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 */
+void make_box(double *ser,long **box,long *list,unsigned long l,
+ unsigned int bs,unsigned int dim,unsigned int del,double eps)
+{
+ int i,x,y;
+ int ib=bs-1;
+
+ for (x=0;x<bs;x++)
+ for (y=0;y<bs;y++)
+ box[x][y] = -1;
+
+ for (i=(dim-1)*del;i<l;i++) {
+ x=(int)(ser[i-(dim-1)*del]/eps)&ib;
+ y=(int)(ser[i]/eps)&ib;
+ list[i]=box[x][y];
+ box[x][y]=i;
+ }
+}
+
--- /dev/null
+/*
+ * 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 */
+void make_multi_box(double **ser,long **box,long *list,unsigned long l,
+ unsigned int bs,unsigned int dim,unsigned int emb,
+ unsigned int del,double eps)
+{
+ int i,x,y;
+ int ib=bs-1;
+
+ for (x=0;x<bs;x++)
+ for (y=0;y<bs;y++)
+ box[x][y] = -1;
+
+ for (i=(emb-1)*del;i<l;i++) {
+ x=(int)(ser[0][i]/eps)&ib;
+ y=(int)(ser[dim-1][i]/eps)&ib;
+ list[i]=box[x][y];
+ box[x][y]=i;
+ }
+}
+
--- /dev/null
+/*
+ * 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:
+ 12/11/05: first version
+*/
+
+void make_multi_box2(double **ser,long **box,long *list,unsigned long l,
+ unsigned int bs,unsigned int dim,unsigned int emb,
+ unsigned int del,double eps)
+{
+ int i,x,y;
+ int ib=bs-1;
+ long back=(emb-1)*del;
+
+ for (x=0;x<bs;x++)
+ for (y=0;y<bs;y++)
+ box[x][y] = -1;
+
+ for (i=back;i<l;i++) {
+ x=(int)(ser[0][i]/eps)&ib;
+ y=(int)(ser[dim-1][i-back]/eps)&ib;
+ list[i]=box[x][y];
+ box[x][y]=i;
+ }
+}
+
--- /dev/null
+/*
+ * 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:
+ 10/12/05: First version
+*/
+/* Comments: Parameters are no. of components of the ts, embedding
+ dimension and optionally the delay
+ return: [0][i] components, [1][i] delay
+*/
+
+#include <stdlib.h>
+
+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<alldim;i++) {
+ mmi[0][i]=i%comps;
+ mmi[1][i]=(i/comps)*del;
+ }
+
+ return mmi;
+}
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#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;
+}
--- /dev/null
+/*
+ * 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 <stdlib.h>
+#endif
+
+#ifndef _LIMITS_H
+#include <limits.h>
+#endif
+
+#ifndef _MATH_H
+#include <math.h>
+#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;
+}
--- /dev/null
+/*
+ * 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 <stdlib.h>
+#endif
+
+#ifndef _LIMITS_H
+#include <limits.h>
+#endif
+
+#ifndef _TIME_H
+#include <time.h>
+#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<nb;i++)
+ box[i]=1;
+
+ for (i=0;i<nx;i++) {
+ h=x[i];
+ if (h >= 1.0)
+ h -= epsinv/2.0;
+ j=(unsigned int)(h*nb);
+ box[j]++;
+ }
+ for (i=1;i<nb;i++)
+ box[i] += box[i-1];
+
+ check_alloc(randarb=(double*)malloc(sizeof(double)*nc));
+
+ if (iseed == 0)
+ iseed=(unsigned long)time((time_t*)&iseed);
+
+ rnd_init(iseed);
+ for (i=0;i<1000;i++)
+ rnd_long();
+
+ for (i=0;i<nc;i++) {
+ hrnd=rnd_long()%nall;
+ for (j=0;j<nb;j++)
+ if (box[j] >= hrnd)
+ break;
+ drnd=(double)rnd_long()/(double)ULONG_MAX*epsinv;
+ randarb[i]=min+((double)j*epsinv+drnd)*inter;
+ }
+
+ free(box);
+
+ return randarb;
+}
--- /dev/null
+/*
+ * 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 <stdlib.h>
+ */
+
+#include <stdio.h>
+#include "tisean_cec.h"
+#include <stdlib.h>
+
+void rescale_data(double *x,unsigned long l,double *min,double *interval)
+{
+ int i;
+
+ *min=*interval=x[0];
+
+ for (i=1;i<l;i++) {
+ if (x[i] < *min) *min=x[i];
+ if (x[i] > *interval) *interval=x[i];
+ }
+ *interval -= *min;
+
+ if (*interval != 0.0) {
+ for (i=0;i<l;i++)
+ x[i]=(x[i]- *min)/ *interval;
+ }
+ else {
+ fprintf(stderr,"rescale_data: data ranges from %e to %e. It makes\n"
+ "\t\tno sense to continue. Exiting!\n\n",*min,*min+(*interval));
+ exit(RESCALE_DATA_ZERO_INTERVAL);
+ }
+}
--- /dev/null
+/*
+ * 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 29th, 1998 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+int scan_help(int n,char **in)
+{
+ int i;
+
+ for (i=1;i<n;i++)
+ if ((in[i][0] == '-') && (in[i][1] == 'h'))
+ return 1;
+ return 0;
+}
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+#include "tsa.h"
+
+char check_col(char *col)
+{
+ int i;
+
+ for (i=0;i<strlen(col);i++)
+ if (!isdigit((unsigned int)col[i])) {
+ fprintf(stderr,"Column must be a unsigned integer. Ignoring it!\n");
+ return 0;
+ }
+ return 1;
+}
+
+char look_for_column(char *name,unsigned int *col)
+{
+ char *hcol,*hname;
+ char vcol=0;
+ int j,in;
+
+ check_alloc(hname=(char*)calloc(strlen(name)+1,1));
+ check_alloc(hcol=(char*)calloc(strlen(name)+1,1));
+ j=0;
+ while (*(name+j) != '\0') {
+ if (*(name+j) == ',') {
+ in=sscanf(name+j+1,"%s",hcol);
+ if (in > 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;
+}
--- /dev/null
+/*
+ * 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 <stdlib.h>
+#include <stdio.h>
+#include <math.h>
+#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<n-1;i++) {
+ max=fabs(mat[i][i]);
+ maxi=i;
+ for (j=i+1;j<n;j++)
+ if ((h=fabs(mat[j][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<n;j++) {
+ q= -mat[j][i]/pivot;
+ mat[j][i]=0.0;
+ for (k=i+1;k<n;k++)
+ mat[j][k] += q*hvec[k];
+ vec[j] += q*vec[i];
+ }
+ }
+ vec[n-1] /= mat[n-1][n-1];
+ for (i=n-2;i>=0;i--) {
+ hvec=mat[i];
+ for (j=n-1;j>i;j--)
+ vec[i] -= hvec[j]*vec[j];
+ vec[i] /= hvec[i];
+ }
+}
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#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);
+}
--- /dev/null
+/*
+ * 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
--- /dev/null
+/*
+ * 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
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#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<l;i++) {
+ h=s[i];
+ *av += h;
+ *var += h*h;
+ }
+ *av /= (double)l;
+ *var=sqrt(fabs((*var)/(double)l-(*av)*(*av)));
+ if (*var == 0.0) {
+ fprintf(stderr,"Variance of the data is zero. Exiting!\n\n");
+ exit(VARIANCE_VAR_EQ_ZERO);
+ }
+}
+
--- /dev/null
+/*
+ * 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: Thomas Schreiber Last modified: 2.Sep, 1999 */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+
+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);
+}
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <limits.h>
+#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<nb;i++) {
+ for (d=0;d<dim;d++)
+ fprintf(stdout,"%e ",(deriv==0)?series[d][i]:0.0);
+ fprintf(stdout,"\n");
+ }
+ for (i=(long)nb;i<length-(long)nf;i++) {
+ for (d=0;d<dim;d++) {
+ help=0.0;
+ for (j= -(long)nb;j<=(long)nf;j++)
+ help += coeff[deriv][j+nb]*series[d][i+j];
+ fprintf(stdout,"%e ",help*norm);
+ }
+ fprintf(stdout,"\n");
+ }
+ for (i=length-(long)nf;i<length;i++) {
+ for (d=0;d<dim;d++)
+ fprintf(stdout,"%e ",(deriv==0)?series[d][i]:0.0);
+ fprintf(stdout,"\n");
+ }
+ }
+ else {
+ fout=fopen(outfile,"w");
+ for (i=0;i<nb;i++) {
+ for (d=0;d<dim;d++)
+ fprintf(fout,"%e ",(deriv==0)?series[d][i]:0.0);
+ fprintf(fout,"\n");
+ }
+ for (i=(long)nb;i<length-(long)nf;i++) {
+ for (d=0;d<dim;d++) {
+ help=0.0;
+ for (j= -(long)nb;j<=(long)nf;j++)
+ help += coeff[deriv][j+nb]*series[d][i+j];
+ fprintf(fout,"%e ",help*norm);
+ }
+ fprintf(fout,"\n");
+ }
+ for (i=length-(long)nf;i<length;i++) {
+ for (d=0;d<dim;d++)
+ fprintf(fout,"%e ",(deriv==0)?series[d][i]:0.0);
+ fprintf(fout,"\n");
+ }
+ fclose(fout);
+ }
+
+ for (i=0;i<dim;i++)
+ free(series[i]);
+ free(series);
+ free(outfile);
+ if (!stdi)
+ free(infile);
+ for (i=0;i<=power;i++)
+ free(coeff[i]);
+ free(coeff);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <limits.h>
+#include <string.h>
+#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<length;j++) {
+ hi=j+i;
+ if ((hi >= 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<length;i++) {
+ array1[i] -= av1;
+ array2[i] -= av2;
+ }
+
+ if (!stout) {
+ fout=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ fprintf(fout,"# average of first comp.=%e\n",av1);
+ fprintf(fout,"# standard deviation of first comp.=%e\n",var1);
+ fprintf(fout,"# average of sec. comp.=%e\n",av2);
+ fprintf(fout,"# standard deviation of sec. comp.=%e\n",var2);
+ }
+ else {
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Writing to stdout\n");
+ fprintf(stdout,"# average of first comp.=%e\n",av1);
+ fprintf(stdout,"# standard deviation of first comp.=%e\n",var1);
+ fprintf(stdout,"# average of sec. comp.=%e\n",av2);
+ fprintf(stdout,"# standard deviation of sec. comp.=%e\n",var2);
+ }
+
+ for (i= -tau;i<=tau;i++)
+ if (!stout) {
+ fprintf(fout,"%ld %e\n",i,corr(i)/var1/var2);
+ fflush(fout);
+ }
+ else {
+ fprintf(stdout,"%ld %e\n",i,corr(i)/var1/var2);
+ fflush(stdout);
+ }
+ if (!stout)
+ fclose(fout);
+
+ return 0;
+}
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#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 <math.h>
+#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<number;i++)
+ casted += series1[found[i]+istep];
+ casted /= number;
+
+ return (casted-series2[act+istep])*(casted-series2[act+istep]);
+}
+
+int main(int argc,char **argv)
+{
+ char stdi=0;
+ char alldone,*done;
+ unsigned long i,j,actfound;
+ unsigned long clength;
+ unsigned int dummy=2;
+ double rms2,av2,*error;
+ double **both,hinter;
+ 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,0L,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.cze",infile);
+ }
+ else {
+ check_alloc(outfile=(char*)calloc((size_t)10,(size_t)1));
+ sprintf(outfile,"stdin.cze");
+ }
+ }
+ if (!stdo)
+ 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)0,verbosity);
+ series1=both[0];
+ series2=both[1];
+ rescale_data(series1,LENGTH,&min,&hinter);
+ interval=hinter;
+ rescale_data(series2,LENGTH,&min,&hinter);
+ interval=(interval+hinter)/2.0;
+
+ variance(series2,LENGTH,&av2,&rms2);
+
+ check_alloc(list=(long*)malloc(sizeof(long)*LENGTH));
+ check_alloc(found=(unsigned long*)malloc(sizeof(long)*LENGTH));
+ check_alloc(done=(char*)malloc(sizeof(char)*LENGTH));
+ check_alloc(box=(long**)malloc(sizeof(long*)*NMAX));
+ check_alloc(error=(double*)malloc(sizeof(double)*STEP));
+ for (i=0;i<STEP;i++)
+ error[i]=0.0;
+
+ for (i=0;i<NMAX;i++)
+ check_alloc(box[i]=(long*)malloc(sizeof(long)*NMAX));
+
+ for (i=0;i<LENGTH;i++)
+ done[i]=0;
+
+ alldone=0;
+ if (epsset)
+ EPS0 /= interval;
+
+ epsilon=EPS0/EPSF;
+ clength=(CLENGTH <= LENGTH) ? CLENGTH-STEP : LENGTH-STEP;
+
+ while (!alldone) {
+ alldone=1;
+ epsilon*=EPSF;
+ make_box(series1,box,list,LENGTH-STEP,NMAX,DIM,DELAY,epsilon);
+ for (i=(DIM-1)*DELAY;i<clength;i++)
+ if (!done[i]) {
+ actfound=find_neighbors(series1,box,list,series2+i,LENGTH,NMAX,
+ DIM,DELAY,epsilon,found);
+ if (actfound >= 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<STEP;i++)
+ fprintf(stdout,"%lu %e\n",i+1,
+ sqrt(error[i]/(clength-(DIM-1)*DELAY))/rms2);
+ }
+ else {
+ file=fopen(outfile,"w");
+ if (verbosity&VER_INPUT)
+ fprintf(stderr,"Opened %s for writing\n",outfile);
+ for (i=0;i<STEP;i++)
+ fprintf(file,"%lu %e\n",i+1,
+ sqrt(error[i]/(clength-(DIM-1)*DELAY))/rms2);
+ fclose(file);
+ }
+
+ return 0;
+}
--- /dev/null
+SHELL = /bin/sh
+
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+BINDIR = ${exec_prefix}/@bindir@
+
+FC = @FC@
+FFLAGS = @FFLAGS@
+LDFLAGS = @LDFLAGS@
+AR = @AR@
+ARFLAGS = @ARFLAGS@
+RANLIB = @RANLIB@
+INSTALL = @INSTALL@
+LOADLIBES = libtsa.a libsla.a
+ERRUNIT = @ERRUNIT@
+
+# list of executables we want to produce
+ BINS = c1 c2naive xc2 \
+ c2d c2g c2t \
+ pc predict stp \
+ lazy project addnoise compare upo upoembed cluster \
+ choose rms notch autocor spectrum wiener1 wiener2 \
+ surrogates endtoend timerev \
+ events intervals spikespec spikeauto \
+ henon ikeda lorenz ar-run xrecur
+
+# list of objects to be put in libtsa.a
+ INC = readfile.o xreadfile.o \
+ arguments.o commandline.o any_s.o istdio.o help.o verbose.o \
+ d1.o neigh.o normal.o rank.o \
+ nmore.o store_spec.o tospec.o
+
+all: $(BINS) Randomize
+
+istdio.o: istdio_temp.f
+ sed "s#ERRUNIT#${ERRUNIT}#" istdio_temp.f > 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) $@)
--- /dev/null
+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
+
--- /dev/null
+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
--- /dev/null
+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
+
--- /dev/null
+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
--- /dev/null
+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
+
+
+
--- /dev/null
+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
--- /dev/null
+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
+
+
--- /dev/null
+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
+
+
+
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
+
+
+
+
+
+
+
+
--- /dev/null
+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
+
--- /dev/null
+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
+
+
--- /dev/null
+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===========================================================================
--- /dev/null
+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
+
--- /dev/null
+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
+
+
--- /dev/null
+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
+
+
--- /dev/null
+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
+
+
--- /dev/null
+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
+
--- /dev/null
+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
--- /dev/null
+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
+
+
+
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
+
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
+
--- /dev/null
+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
+
--- /dev/null
+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
--- /dev/null
+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
+
--- /dev/null
+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
+
--- /dev/null
+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
+
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
+
--- /dev/null
+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
+
--- /dev/null
+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
+
--- /dev/null
+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
+
+
--- /dev/null
+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 *~ #*#
--- /dev/null
+*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
--- /dev/null
+ 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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+ 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
+
+
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+*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
--- /dev/null
+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
--- /dev/null
+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
+
+
+
--- /dev/null
+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
+
+
+
--- /dev/null
+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
--- /dev/null
+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
+
+
+
+
+
--- /dev/null
+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
+
--- /dev/null
+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
+
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
+
+
--- /dev/null
+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
+
+
+
+
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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>---------------------------------------------------------------------
+
+
+
+
+
+
--- /dev/null
+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
+
+
+
--- /dev/null
+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>------------------------------------
--- /dev/null
+ integer argv
+ argv=6
+c call getarg(1,argv)
+ write(99,*) argv
+ call FLUSH(99)
+ end
git://source.jalview.org / jabaws.git / commitdiff