Mercurial > forge
changeset 9895:c3f84679e613 octave-forge
system-identification: removing big collection and adding only under development
author | jpicarbajal |
---|---|
date | Wed, 28 Mar 2012 13:55:12 +0000 |
parents | 82ff20b4d849 |
children | ad01348bb05b |
files | main/system-identification/devel/tisean/source_c/Makefile.in main/system-identification/devel/tisean/source_c/ar-model.c main/system-identification/devel/tisean/source_c/arima-model.c main/system-identification/devel/tisean/source_c/av-d2.c main/system-identification/devel/tisean/source_c/boxcount.c main/system-identification/devel/tisean/source_c/corr.c main/system-identification/devel/tisean/source_c/d2.c main/system-identification/devel/tisean/source_c/delay.c main/system-identification/devel/tisean/source_c/extrema.c main/system-identification/devel/tisean/source_c/false_nearest.c main/system-identification/devel/tisean/source_c/fsle.c main/system-identification/devel/tisean/source_c/ghkss.c main/system-identification/devel/tisean/source_c/histogram.c main/system-identification/devel/tisean/source_c/lfo-ar.c main/system-identification/devel/tisean/source_c/lfo-run.c main/system-identification/devel/tisean/source_c/lfo-test.c main/system-identification/devel/tisean/source_c/low121.c main/system-identification/devel/tisean/source_c/lyap_k.c main/system-identification/devel/tisean/source_c/lyap_r.c main/system-identification/devel/tisean/source_c/lyap_spec.c main/system-identification/devel/tisean/source_c/lzo-gm.c main/system-identification/devel/tisean/source_c/lzo-run.c main/system-identification/devel/tisean/source_c/lzo-test.c main/system-identification/devel/tisean/source_c/makenoise.c main/system-identification/devel/tisean/source_c/mem_spec.c main/system-identification/devel/tisean/source_c/mutual.c main/system-identification/devel/tisean/source_c/new.tgz main/system-identification/devel/tisean/source_c/nrlazy.c main/system-identification/devel/tisean/source_c/nstat_z.c main/system-identification/devel/tisean/source_c/pca.c main/system-identification/devel/tisean/source_c/poincare.c main/system-identification/devel/tisean/source_c/polyback.c main/system-identification/devel/tisean/source_c/polynom.c main/system-identification/devel/tisean/source_c/polynomp.c main/system-identification/devel/tisean/source_c/polypar.c main/system-identification/devel/tisean/source_c/rbf.c main/system-identification/devel/tisean/source_c/recurr.c main/system-identification/devel/tisean/source_c/resample.c main/system-identification/devel/tisean/source_c/rescale.c main/system-identification/devel/tisean/source_c/routines/Makefile.in main/system-identification/devel/tisean/source_c/routines/arima.tgz main/system-identification/devel/tisean/source_c/routines/check_alloc.c main/system-identification/devel/tisean/source_c/routines/check_option.c main/system-identification/devel/tisean/source_c/routines/diffc.log main/system-identification/devel/tisean/source_c/routines/diffh.log main/system-identification/devel/tisean/source_c/routines/eigen.c main/system-identification/devel/tisean/source_c/routines/exclude_interval.c main/system-identification/devel/tisean/source_c/routines/find_multi_neighbors.c main/system-identification/devel/tisean/source_c/routines/find_neighbors.c main/system-identification/devel/tisean/source_c/routines/get_multi_series.c main/system-identification/devel/tisean/source_c/routines/get_series.c main/system-identification/devel/tisean/source_c/routines/invert_matrix.c main/system-identification/devel/tisean/source_c/routines/make_box.c main/system-identification/devel/tisean/source_c/routines/make_multi_box.c main/system-identification/devel/tisean/source_c/routines/make_multi_box2.c main/system-identification/devel/tisean/source_c/routines/make_multi_index.c main/system-identification/devel/tisean/source_c/routines/myfgets.c main/system-identification/devel/tisean/source_c/routines/rand.c main/system-identification/devel/tisean/source_c/routines/rand_arb_dist.c main/system-identification/devel/tisean/source_c/routines/rescale_data.c main/system-identification/devel/tisean/source_c/routines/scan_help.c main/system-identification/devel/tisean/source_c/routines/search_datafile.c main/system-identification/devel/tisean/source_c/routines/solvele.c main/system-identification/devel/tisean/source_c/routines/test_outfile.c main/system-identification/devel/tisean/source_c/routines/tisean_cec.h main/system-identification/devel/tisean/source_c/routines/tsa.h main/system-identification/devel/tisean/source_c/routines/variance.c main/system-identification/devel/tisean/source_c/routines/what_i_do.c main/system-identification/devel/tisean/source_c/sav_gol.c main/system-identification/devel/tisean/source_c/xcor.c main/system-identification/devel/tisean/source_c/xzero.c main/system-identification/devel/tisean/source_f/Makefile.in main/system-identification/devel/tisean/source_f/addnoise.f main/system-identification/devel/tisean/source_f/any_s.f main/system-identification/devel/tisean/source_f/ar-run.f main/system-identification/devel/tisean/source_f/arguments.f main/system-identification/devel/tisean/source_f/autocor.f main/system-identification/devel/tisean/source_f/c1.f main/system-identification/devel/tisean/source_f/c2d.f main/system-identification/devel/tisean/source_f/c2g.f main/system-identification/devel/tisean/source_f/c2naive.f main/system-identification/devel/tisean/source_f/c2t.f main/system-identification/devel/tisean/source_f/choose.f main/system-identification/devel/tisean/source_f/cluster.f main/system-identification/devel/tisean/source_f/commandline.f main/system-identification/devel/tisean/source_f/compare.f main/system-identification/devel/tisean/source_f/d1.f main/system-identification/devel/tisean/source_f/endtoend.f main/system-identification/devel/tisean/source_f/events.f main/system-identification/devel/tisean/source_f/gpl.txt main/system-identification/devel/tisean/source_f/help.f main/system-identification/devel/tisean/source_f/henon.f main/system-identification/devel/tisean/source_f/ikeda.f main/system-identification/devel/tisean/source_f/intervals.f main/system-identification/devel/tisean/source_f/istdio_temp.f main/system-identification/devel/tisean/source_f/lazy.f main/system-identification/devel/tisean/source_f/lorenz.f main/system-identification/devel/tisean/source_f/neigh.f main/system-identification/devel/tisean/source_f/nmore.f main/system-identification/devel/tisean/source_f/normal.f main/system-identification/devel/tisean/source_f/notch.f main/system-identification/devel/tisean/source_f/pc.f main/system-identification/devel/tisean/source_f/predict.f main/system-identification/devel/tisean/source_f/project.f main/system-identification/devel/tisean/source_f/randomize/Makefile.in main/system-identification/devel/tisean/source_f/randomize/cool/exp.f main/system-identification/devel/tisean/source_f/randomize/cost/auto.f main/system-identification/devel/tisean/source_f/randomize/cost/autop.f main/system-identification/devel/tisean/source_f/randomize/cost/spikeauto.f main/system-identification/devel/tisean/source_f/randomize/cost/spikespec.f main/system-identification/devel/tisean/source_f/randomize/cost/uneven.f main/system-identification/devel/tisean/source_f/randomize/perm/event.f main/system-identification/devel/tisean/source_f/randomize/perm/random.f main/system-identification/devel/tisean/source_f/randomize/randomize.f main/system-identification/devel/tisean/source_f/rank.f main/system-identification/devel/tisean/source_f/readfile.f main/system-identification/devel/tisean/source_f/rms.f main/system-identification/devel/tisean/source_f/slatec/Makefile.in main/system-identification/devel/tisean/source_f/slatec/chkder.f main/system-identification/devel/tisean/source_f/slatec/d1mach.f main/system-identification/devel/tisean/source_f/slatec/dqk15.f main/system-identification/devel/tisean/source_f/slatec/enorm.f main/system-identification/devel/tisean/source_f/slatec/fdjac3.f main/system-identification/devel/tisean/source_f/slatec/fdump.f main/system-identification/devel/tisean/source_f/slatec/i1mach.f main/system-identification/devel/tisean/source_f/slatec/j4save.f main/system-identification/devel/tisean/source_f/slatec/lmpar.f main/system-identification/devel/tisean/source_f/slatec/pythag.f main/system-identification/devel/tisean/source_f/slatec/qrfac.f main/system-identification/devel/tisean/source_f/slatec/qrsolv.f main/system-identification/devel/tisean/source_f/slatec/r1mach.f main/system-identification/devel/tisean/source_f/slatec/radb2.f main/system-identification/devel/tisean/source_f/slatec/radb3.f main/system-identification/devel/tisean/source_f/slatec/radb4.f main/system-identification/devel/tisean/source_f/slatec/radb5.f main/system-identification/devel/tisean/source_f/slatec/radbg.f main/system-identification/devel/tisean/source_f/slatec/radf2.f main/system-identification/devel/tisean/source_f/slatec/radf3.f main/system-identification/devel/tisean/source_f/slatec/radf4.f main/system-identification/devel/tisean/source_f/slatec/radf5.f main/system-identification/devel/tisean/source_f/slatec/radfg.f main/system-identification/devel/tisean/source_f/slatec/rand.f main/system-identification/devel/tisean/source_f/slatec/rfftb1.f main/system-identification/devel/tisean/source_f/slatec/rfftf1.f main/system-identification/devel/tisean/source_f/slatec/rffti1.f main/system-identification/devel/tisean/source_f/slatec/rgauss.f main/system-identification/devel/tisean/source_f/slatec/rs.f main/system-identification/devel/tisean/source_f/slatec/rwupdt.f main/system-identification/devel/tisean/source_f/slatec/snls1.f main/system-identification/devel/tisean/source_f/slatec/tql2.f main/system-identification/devel/tisean/source_f/slatec/tqlrat.f main/system-identification/devel/tisean/source_f/slatec/tred1.f main/system-identification/devel/tisean/source_f/slatec/tred2.f main/system-identification/devel/tisean/source_f/slatec/xercnt.f main/system-identification/devel/tisean/source_f/slatec/xerhlt.f main/system-identification/devel/tisean/source_f/slatec/xermsg.f main/system-identification/devel/tisean/source_f/slatec/xerprn.f main/system-identification/devel/tisean/source_f/slatec/xersve.f main/system-identification/devel/tisean/source_f/slatec/xgetua.f main/system-identification/devel/tisean/source_f/spectrum.f main/system-identification/devel/tisean/source_f/spikeauto.f main/system-identification/devel/tisean/source_f/spikespec.f main/system-identification/devel/tisean/source_f/store_spec.f main/system-identification/devel/tisean/source_f/stp.f main/system-identification/devel/tisean/source_f/surrogates.f main/system-identification/devel/tisean/source_f/timerev.f main/system-identification/devel/tisean/source_f/tospec.f main/system-identification/devel/tisean/source_f/totospec.f main/system-identification/devel/tisean/source_f/upo.f main/system-identification/devel/tisean/source_f/upoembed.f main/system-identification/devel/tisean/source_f/verbose.f main/system-identification/devel/tisean/source_f/wiener1.f main/system-identification/devel/tisean/source_f/wiener2.f main/system-identification/devel/tisean/source_f/xc2.f main/system-identification/devel/tisean/source_f/xreadfile.f main/system-identification/devel/tisean/source_f/xrecur.f main/system-identification/devel/tisean/src/delay.c main/system-identification/devel/tisean/src/tisean_functions.cc |
diffstat | 177 files changed, 332 insertions(+), 28970 deletions(-) [+] |
line wrap: on
line diff
--- a/main/system-identification/devel/tisean/source_c/Makefile.in Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,47 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_c/ar-model.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,395 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/arima-model.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,721 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/av-d2.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,188 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/boxcount.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,369 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/corr.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,179 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/d2.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,587 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/delay.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,331 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/extrema.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,225 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/false_nearest.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,328 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/fsle.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,304 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/ghkss.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,503 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/histogram.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,170 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/lfo-ar.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,390 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/lfo-run.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,456 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/lfo-test.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,462 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/low121.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,173 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/lyap_k.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,341 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/lyap_r.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,251 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/lyap_spec.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,574 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/lzo-gm.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,293 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/lzo-run.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,411 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/lzo-test.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,345 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/makenoise.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,254 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/mem_spec.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,242 +0,0 @@ -/* - * 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; -} -
--- a/main/system-identification/devel/tisean/source_c/mutual.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,206 +0,0 @@ -/* - * 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; -} -
--- a/main/system-identification/devel/tisean/source_c/nrlazy.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,383 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/nstat_z.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,486 +0,0 @@ -/* - * 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; -} -
--- a/main/system-identification/devel/tisean/source_c/pca.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,329 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/poincare.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,241 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/polyback.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,355 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/polynom.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,322 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/polynomp.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,299 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/polypar.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,121 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/rbf.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,383 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/recurr.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,225 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/resample.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,174 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/rescale.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,185 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/routines/Makefile.in Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,21 +0,0 @@ -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 *~ #*#
--- a/main/system-identification/devel/tisean/source_c/routines/check_alloc.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ -/* - * 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); - } -}
--- a/main/system-identification/devel/tisean/source_c/routines/check_option.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,252 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/routines/diffc.log Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,11 +0,0 @@ ---- 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]);
--- a/main/system-identification/devel/tisean/source_c/routines/eigen.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,522 +0,0 @@ -#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); -}
--- a/main/system-identification/devel/tisean/source_c/routines/exclude_interval.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/routines/find_multi_neighbors.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/routines/find_neighbors.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/routines/get_multi_series.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,190 +0,0 @@ -/* - * 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
--- a/main/system-identification/devel/tisean/source_c/routines/get_series.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,110 +0,0 @@ -/* - * 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
--- a/main/system-identification/devel/tisean/source_c/routines/invert_matrix.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/routines/make_box.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,38 +0,0 @@ -/* - * 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; - } -} -
--- a/main/system-identification/devel/tisean/source_c/routines/make_multi_box.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -/* - * 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; - } -} -
--- a/main/system-identification/devel/tisean/source_c/routines/make_multi_box2.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,44 +0,0 @@ -/* - * 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; - } -} -
--- a/main/system-identification/devel/tisean/source_c/routines/make_multi_index.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/routines/myfgets.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,54 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/routines/rand.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,157 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/routines/rand_arb_dist.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/routines/rescale_data.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* - * 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); - } -}
--- a/main/system-identification/devel/tisean/source_c/routines/scan_help.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,33 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/routines/search_datafile.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,125 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/routines/solvele.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -/* - * 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]; - } -}
--- a/main/system-identification/devel/tisean/source_c/routines/test_outfile.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,35 +0,0 @@ -/* - * 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); -}
--- a/main/system-identification/devel/tisean/source_c/routines/tisean_cec.h Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,85 +0,0 @@ -/* - * 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
--- a/main/system-identification/devel/tisean/source_c/routines/tsa.h Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,105 +0,0 @@ -/* - * 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
--- a/main/system-identification/devel/tisean/source_c/routines/variance.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -/* - * 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); - } -} -
--- a/main/system-identification/devel/tisean/source_c/routines/what_i_do.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ -/* - * 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); -}
--- a/main/system-identification/devel/tisean/source_c/sav_gol.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,257 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/xcor.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,186 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_c/xzero.c Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,237 +0,0 @@ -/* - * 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; -}
--- a/main/system-identification/devel/tisean/source_f/Makefile.in Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,71 +0,0 @@ -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) $@)
--- a/main/system-identification/devel/tisean/source_f/addnoise.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,102 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/any_s.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/ar-run.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,99 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/arguments.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,159 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/autocor.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,96 +0,0 @@ -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 - - -
--- a/main/system-identification/devel/tisean/source_f/c1.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,92 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/c2d.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,90 +0,0 @@ -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 - -
--- a/main/system-identification/devel/tisean/source_f/c2g.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,109 +0,0 @@ -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 - - -
--- a/main/system-identification/devel/tisean/source_f/c2naive.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,120 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/c2t.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,81 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/choose.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,60 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/cluster.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,195 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/commandline.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,162 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/compare.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,72 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/d1.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,116 +0,0 @@ -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 - - - - - - - -
--- a/main/system-identification/devel/tisean/source_f/endtoend.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,120 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/events.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -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 - -
--- a/main/system-identification/devel/tisean/source_f/gpl.txt Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,21 +0,0 @@ -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===========================================================================
--- a/main/system-identification/devel/tisean/source_f/help.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,80 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/henon.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -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 - -
--- a/main/system-identification/devel/tisean/source_f/ikeda.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ -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 - -
--- a/main/system-identification/devel/tisean/source_f/intervals.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ -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 - -
--- a/main/system-identification/devel/tisean/source_f/istdio_temp.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,44 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/lazy.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,109 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/lorenz.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,311 +0,0 @@ -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 - - -
--- a/main/system-identification/devel/tisean/source_f/neigh.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,182 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/nmore.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,58 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/normal.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/notch.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,86 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/pc.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,96 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/predict.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,104 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/project.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,172 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/randomize/Makefile.in Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,53 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/randomize/cool/exp.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,127 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/randomize/cost/auto.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,174 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/randomize/cost/autop.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,181 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/randomize/cost/spikeauto.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,265 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/randomize/cost/spikespec.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,251 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/randomize/cost/uneven.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,260 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/randomize/perm/event.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,81 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/randomize/perm/random.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,109 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/randomize/randomize.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,127 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/rank.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,153 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/readfile.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,186 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/rms.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,82 +0,0 @@ -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 - -
--- a/main/system-identification/devel/tisean/source_f/slatec/Makefile.in Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ -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 *~ #*#
--- a/main/system-identification/devel/tisean/source_f/slatec/chkder.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,158 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/d1mach.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,19 +0,0 @@ - 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
--- a/main/system-identification/devel/tisean/source_f/slatec/dqk15.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,185 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/enorm.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,117 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/fdjac3.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,114 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/fdump.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/i1mach.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,142 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/j4save.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/lmpar.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,267 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/pythag.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/qrfac.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,170 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/qrsolv.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,198 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/r1mach.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,21 +0,0 @@ - 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 - -
--- a/main/system-identification/devel/tisean/source_f/slatec/radb2.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,61 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/radb3.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,85 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/radb4.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,109 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/radb5.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,132 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/radbg.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,189 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/radf2.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,61 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/radf3.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/radf4.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,105 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/radf5.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,128 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/radfg.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,194 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/rand.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,122 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/rfftb1.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,143 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/rfftf1.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,144 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/rffti1.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,110 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/rgauss.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/rs.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,90 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/rwupdt.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,120 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/snls1.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1023 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/tql2.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,203 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/tqlrat.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,165 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/tred1.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,142 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/tred2.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,166 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/xercnt.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/xerhlt.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/xermsg.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,364 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/xerprn.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,228 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/xersve.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,155 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/slatec/xgetua.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -*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
--- a/main/system-identification/devel/tisean/source_f/spectrum.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,79 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/spikeauto.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,81 +0,0 @@ -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 - - -
--- a/main/system-identification/devel/tisean/source_f/spikespec.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,105 +0,0 @@ -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 - - -
--- a/main/system-identification/devel/tisean/source_f/store_spec.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/stp.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,104 +0,0 @@ -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 - - - - -
--- a/main/system-identification/devel/tisean/source_f/surrogates.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,179 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/timerev.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,61 +0,0 @@ -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 -
--- a/main/system-identification/devel/tisean/source_f/tospec.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,53 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/totospec.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/upo.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,268 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/upoembed.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -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 - -
--- a/main/system-identification/devel/tisean/source_f/verbose.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,98 +0,0 @@ -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 - - - -
--- a/main/system-identification/devel/tisean/source_f/wiener1.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,85 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/wiener2.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,95 +0,0 @@ -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
--- a/main/system-identification/devel/tisean/source_f/xc2.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,244 +0,0 @@ -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>--------------------------------------------------------------------- - - - - - -
--- a/main/system-identification/devel/tisean/source_f/xreadfile.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,103 +0,0 @@ -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 - - -
--- a/main/system-identification/devel/tisean/source_f/xrecur.f Wed Mar 28 13:32:37 2012 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,402 +0,0 @@ -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 Thu Jan 01 00:00:00 1970 +0000 +++ b/main/system-identification/devel/tisean/src/delay.c Wed Mar 28 13:55:12 2012 +0000 @@ -0,0 +1,331 @@ +/* + * 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; +}