new file mode 100755
--- /dev/null
+++ b/ANTSlib
@@ -0,0 +1,35 @@
+#!/usr/bin/perl
+#======================================================================
+# A N T S L I B
+# doc: Wed May 16 06:19:16 2012
+# dlm: Wed May 16 06:28:16 2012
+# (c) 2012 A.M. Thurnherr
+# uE-Info: 11 36 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# May 16, 2012: - created for V5.0
+
+($ANTSlib) = ($0 =~ m{^(.*)/[^/]*$});
+
+require "$ANTSlib/ants.pl";
+require "$ANTSlib/libCPT.pl";
+require "$ANTSlib/libEOS83.pl";
+require "$ANTSlib/libGM.pl";
+require "$ANTSlib/libLADCP.pl";
+require "$ANTSlib/libNODC.pl";
+require "$ANTSlib/libPOSIX.pl";
+require "$ANTSlib/libRWalk.pl";
+require "$ANTSlib/libWOCE.pl";
+require "$ANTSlib/libWOCE_oldstyle.pl";
+require "$ANTSlib/libconv.pl";
+require "$ANTSlib/libfuns.pl";
+require "$ANTSlib/libgamma.pl";
+require "$ANTSlib/libstats.pl";
+require "$ANTSlib/libtides.pl";
+require "$ANTSlib/libubtest.pl";
+require "$ANTSlib/libvec.pl";
+
+chomp($about = `sed -n '/^description =/s/description = //p' $ANTSlib/.hg/hgrc`);
+print(STDERR "$about installed in $ANTSlib\n");
+exit(0);
new file mode 100644
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,16 @@
+#======================================================================
+# M A K E F I L E
+# doc: Tue May 15 18:12:31 2012
+# dlm: Wed May 16 06:29:19 2012
+# (c) 2012 A.M. Thurnherr
+# uE-Info: 16 20 NIL 0 0 72 0 2 4 NIL ofnI
+#======================================================================
+
+.PHONY: version
+version:
+ @sed -n '/^description =/s/description = //p' .hg/hgrc
+
+.PHONY: publish
+publish:
+ cd ..; \
+ scp -Cr ANTSlib miles:public_hg
new file mode 100644
--- /dev/null
+++ b/README
@@ -0,0 +1,22 @@
+======================================================================
+ R E A D M E
+ doc: Tue May 15 18:10:40 2012
+ dlm: Wed May 16 06:30:40 2012
+ (c) 2012 A.M. Thurnherr
+ uE-Info: 19 0 NIL 0 0 72 3 2 4 NIL ofnI
+======================================================================
+
+This directory contains a set of perl libraries written and copyrighted
+by A.M. Thurnherr. The software is written in perl (V5.12.4 or later
+should work) and assumed to run in a UN*X environment.
+
+To find out which version you have, run "make" in current directory.
+
+Most of the source files use a hard tab of 4 spaces, i.e. they can be
+viewed correctly, e.g. with "less -x4".
+
+There is currently no documentation, nor is there support.
+
+SOFTWARE CAN BE FREELY USED AND COPIED FOR EDUCATIONAL OR OTHER
+NOT-FOR-PROFIT PURPOSES.
+
new file mode 100644
--- /dev/null
+++ b/amoeba.pl
@@ -0,0 +1,125 @@
+#======================================================================
+# A M O E B A . P L
+# doc: Wed Aug 23 05:11:48 2006
+# dlm: Wed Aug 23 23:52:12 2006
+# (c) 2006 A.M. Thurnherr
+# uE-Info: 88 0 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# perlified amoeba implementation of NR code
+
+# NOTES:
+# - 0-based arrays
+# - amoeba returns undef if NMAX is exceeded and # of evals otherwise
+
+use strict;
+
+sub amotry($$$$$$)
+{
+ my($pR,$yR,$psumR,$funR,$ihi,$fac) = @_;
+ my(@ptry);
+
+ my($ndim) = scalar(@{$pR->[0]});
+ my($fac1) = (1-$fac) / $ndim;
+ my($fac2) = $fac1 - $fac;
+
+ for (my($j)=0; $j<$ndim; $j++) {
+ $ptry[$j] = $psumR->[$j]*$fac1 - $pR->[$ihi][$j]*$fac2;
+ }
+ my($ytry) = &$funR(@ptry);
+ if ($ytry < $yR->[$ihi]) {
+ $yR->[$ihi] = $ytry;
+ for (my($j)=0; $j<$ndim; $j++) {
+ $psumR->[$j] += $ptry[$j] - $pR->[$ihi][$j];
+ $pR->[$ihi][$j] = $ptry[$j];
+ }
+ }
+ return $ytry;
+}
+
+sub get_psum($$)
+{
+ my($pR,$psumR) = @_;
+
+ for (my($j)=0; $j<@{$pR->[0]}; $j++) {
+ my($sum);
+ for ($sum=my($i)=0; $i<=@{$pR->[0]}; $i++) {
+ $sum += $pR->[$i][$j];
+ }
+ $psumR->[$j] = $sum;
+ }
+}
+
+sub amoeba($$$$)
+{
+ my($pR,$yR,$ftol,$funR,$NMAX) = @_;
+ my($nfunk) = 0;
+ my($ndim) = scalar(@{$pR->[0]});
+ my(@psum);
+
+ &get_psum($pR,\@psum);
+
+ while (1) {
+ my($i,$ihi,$inhi,$j);
+ my($sum);
+
+ my($ilo) = 0;
+ if ($yR->[0] > $yR->[1]) {
+ $ihi = 0; $inhi = 1;
+ } else {
+ $ihi = 1; $inhi = 0;
+ }
+
+ for ($i=0; $i<$ndim+1; $i++) {
+ if ($yR->[$i] <= $yR->[$ilo]) {
+ $ilo = $i;
+ }
+ if ($yR->[$i] > $yR->[$ihi]) {
+ $inhi = $ihi;
+ $ihi = $i;
+ } elsif ($yR->[$i] > $yR->[$inhi] && $i != $ihi) {
+ $inhi = $i;
+ }
+ }
+ print(STDERR "best = $yR->[$ilo]\n");
+
+ my($rtol) = 2 * abs($yR->[$ihi] - $yR->[$ilo]) /
+ (abs($yR->[$ihi]) + abs($yR->[$ilo]));
+ if ($rtol < $ftol) {
+ my($tmp) = $yR->[0]; $yR->[0] = $yR->[$ilo]; $yR->[$ilo] = $tmp;
+ for ($i=0; $i<$ndim; $i++) {
+ my($tmp) = $pR->[1][$i]; $pR->[1][$i] = $pR->[$ilo][$i];
+ $pR->[$ilo][$i] = $tmp;
+ }
+ return $nfunk;
+ }
+
+ return undef if ($nfunk >= $NMAX);
+ $nfunk += 2;
+
+ my($ytry) = amotry($pR,$yR,\@psum,$funR,$ihi,-1);
+ if ($ytry <= $yR->[$ilo]) {
+ $ytry = amotry($pR,$yR,\@psum,$funR,$ihi,2);
+ } elsif ($ytry >= $yR->[$inhi]) {
+ my($ysave) = $yR->[$ihi];
+ $ytry = amotry($pR,$yR,\@psum,$funR,$ihi,0.5);
+ if ($ytry >= $ysave) {
+ for ($i=0; $i<$ndim+1; $i++) {
+ if ($i != $ilo) {
+ for ($j=0; $j<$ndim; $j++) {
+ $pR->[$i][$j] = $psum[$j] =
+ 0.5 * ($pR->[$i][$j] + $pR->[$ilo][$j]);
+ }
+ $yR->[$i] = &$funR(@psum);
+ }
+ }
+ $nfunk += $ndim;
+ &get_psum($pR,\@psum);
+ }
+ } else {
+ --$nfunk;
+ }
+ }
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/ants.pl
@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+#======================================================================
+# A N T S . P L
+# doc: Fri Jun 19 14:01:06 1998
+# dlm: Wed Jul 5 15:37:12 2006
+# (c) 1998 A.M. Thurnherr
+# uE-Info: 18 0 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Jun 19, 1998: - apparently created
+# Jul 3, 2006: - added support for ANTS_PERL
+# Jul 5, 2006: - removed `basename`
+# Jul 19, 2006: - added error if exec($ANTS_PERL) fails
+
+exec($ENV{ANTS_PERL},$0,@ARGV),die("$ENV{ANTS_PERL}: $!")
+ if (defined($ENV{ANTS_PERL}) && $^X ne $ENV{ANTS_PERL});
+
+($ANTS) = ($0 =~ m{^(.*)/[^/]*$}) unless defined($ANTS);
+
+require "$ANTS/antsusage.pl";
+require "$ANTS/antsio.pl";
+require "$ANTS/antsutils.pl";
+require "$ANTS/antsexprs.pl";
+
+1;
new file mode 100644
--- /dev/null
+++ b/antsdebug.pl
@@ -0,0 +1,34 @@
+#======================================================================
+# A N T S D E B U G . P L
+# doc: Sat Mar 21 14:18:37 2009
+# dlm: Thu Aug 20 22:41:38 2009
+# (c) 2009 A.M. Thurnherr
+# uE-Info: 11 55 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Mar 21, 2009: - created from [abc]
+# Aug 20, 2009: tried to change prompt, to no avail...
+
+{ my($term);
+
+sub debug()
+{
+ unless (defined($term)) {
+ use Term::ReadLine;
+ $term = new Term::ReadLine 'debug';
+ }
+ do {
+ my($expr) = $term->readline;
+ return if ($expr eq 'return');
+ $res = eval($expr);
+ if (defined($res)) { # no error
+ print(STDERR "$res\n");
+ } else { # error
+ print(STDERR "$@");
+ }
+ }
+}
+
+}
+1;
new file mode 100644
--- /dev/null
+++ b/antsexprs.pl
@@ -0,0 +1,326 @@
+#======================================================================
+# A N T S E X P R S . P L
+# (c) 2005 Andreas Thurnherr
+# doc: Sat Dec 31 18:35:33 2005
+# dlm: Sat Mar 10 16:28:46 2012
+# uE-Info: 207 38 NIL 0 0 70 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Dec 31, 2005: - extracted from [list]
+# Jan 2, 2006: - re-written to use anonymous funs instead of eval()
+# Jan 3, 2006: - added $DEBUG
+# Jan 4, 2006: - removed NaN_handling_out
+# Jan 9, 2006: - made $bufvar param to antsCompileExpr optional
+# Jan 13, 2006: - separated AddrExpr from EditExpr
+# - implemented abbreviated addr exprs
+# Jan 14, 2006: - added old -G syntax to -S
+# Jan 17, 2006: - BUG: $1, $2, did not work in abbrevs
+# Jan 31, 2006: - added de-octalization code for abbrevs
+# Apr 11, 2006: - added ,-separated list (again?)
+# May 18, 2006: - fiddled
+# Jun 20, 2006: - simplified regexprs; fields can now begin with _
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+# Jul 24, 2006: - BUG: $$ did not work as advertised
+# Dec 11, 2006: - BUG: 1e-3 was not recognized as a valid number in
+# abbreviations
+# Dec 1, 2007: - improved to allow -S%PARAM:... (mainly for %RECNO)
+# Jan 20, 2007: - pointless debugging (BUGs in [fnr] [list])
+# Mar 26, 2008: - BUG: . were not allowed in field names
+# Mar 27, 2008: - added &antsCompileConstExpr()
+# Mar 28, 2008: - made compile funs bomb on undefined %PARAMs
+# Aug 27, 2008: - generate error on list(1)-specific address expressions
+# Oct 12, 2008: - BUG: -S%RECNO%%6==1 did not work because %-escape magic
+# word continued RECNO word to form undefined PARAM
+# name. Solution: begin/end escape magic words for %
+# and $ with a space (nonword character)
+# Oct 5, 2009: - improved documentation
+# - added $antsEditExprUsesFields flag
+# Dec 10, 2009: - BUG: debug output had been wrong for ConstExprs
+# - modified semantics to allow for : in param names
+# May 21, 2011: - added support for $antsFnrNegativeOk
+# May 22, 2011: - made it work
+# Feb 20, 2012: - BUG: quoting had not been implemented
+# Mar 10, 2012: - added ${field..field} syntax to edit exprs
+
+$DEBUG = 0;
+
+#----------------------------------------------------------------------
+# Address Expressions
+# - return value indicates whether current record matches
+# - any valid PERL expression can be an addr expr
+# - $id are assumed to be fields (use $$id for perl vars)
+# - %id are assumed to be PARAMs (use %% to get %)
+# - ABBREVIATIONS:
+# - id1 relop id2 becomes numberp(id1) && numberp(id2) && $id1 relop $id2
+# - id1 relop id2 relop id3 is analogous
+# - id? can only be restricted field name ([\w\.] chars and, possibly, leading %)
+# - non-perl relops ~=, <> become !=
+#----------------------------------------------------------------------
+
+sub antsCompileAddrExpr($) # subst fields/%PARAMs
+{
+ my($expr,$bufVar) = @_;
+ $bufVar = '$ants_[0]' unless (length($bufVar) > 0);
+
+ #---------------------
+ # handle abbreviations
+ #---------------------
+ print(STDERR "IN AddrExpr = $expr\n") if ($DEBUG);
+
+ goto QUOTED_ADDR_EXPR
+ if ((substr($expr,0,1) eq "'" || substr($expr,0,1) eq '"') &&
+ (substr($expr,0,1) eq substr($expr,-1)));
+
+ # NB: update following code if -S extensions in [list] change
+ croak("$0: unsupported list(1)-specific address expression <$expr>\n")
+ if ($expr =~ /^\$?([\w\.]+)\s*~(([nN][aA][nN])|(([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?))/ ||
+ $expr =~ /^\$?([\w\.]+)\s*<$/ ||
+ $expr =~ /^<\$?([\w\.]+)$/ ||
+ $expr =~ /^\$?([\w\.]+)\s*>$/ ||
+ $expr =~ /^>\$?([\w\.]+)$/);
+
+ if ($expr =~ /^(%?[\w\.]+):/ || $expr =~ /^(\$\d+):/) { # old -G syntax
+ my($fname) = $1; my($range) = $';
+ if ($range =~ /(.*)\.\.(.*)/) {
+ my($min) = ($1 eq '*') ? -1e99 : $1;
+ my($max) = ($2 eq '*') ? 1e99 : $2;
+ croak("$0: illegal addr-expr $expr\n")
+ unless ((numberp($min) || $min =~ /^%/) &&
+ (numberp($max) || $max =~ /^%/));
+ $expr = "$min<=$fname<=$max";
+ } else {
+ if ($range eq '*') {
+ $expr = "numberp(\$$fname)";
+ } else {
+ my(@vl) = split(/,/,$range);
+ $vl[0] = str2num($vl[0]);
+ if (numberp($vl[0]) || $vl[0] =~ /^%/) {
+ $expr = "\$$fname==$vl[0]";
+ } else {
+ $expr = "\$$fname=~/$vl[0]/";
+ }
+ for (my($vi)=1; $vi<=$#vl; $vi++) {
+ $vl[$vi] = str2num($vl[$vi]);
+ if (numberp($vl[$vi]) || $vl[$vi] =~ /^%/) {
+ $expr .= "||\$$fname==$vl[$vi]";
+ } else {
+ $expr .= "||\$$fname=~/$vl[$vi]/";
+ }
+ }
+ }
+ }
+ print(STDERR "-G AddrExpr = $expr\n") if ($DEBUG);
+ }
+
+ my($relop) = '<|<=|>|>=|!=|~=|<>|=='; # relational ops
+ my($comparee) = '-?%?\$?[\w\.\+\-]+'; # nums, fields, PARAMs
+ my($numvar) = '^[\w\.]+$'; # fields
+
+ if ($expr =~ /^($comparee)\s*($relop)\s*($comparee)$/) {
+ my($c1) = $1; my($c2) = $3; my($ro) = $2;
+ $c1 =~ s/^0*(\d)/\1/; $c2 =~ s/^0*(\d)/\1/; # de-octalize
+ $ro = '!=' if ($ro eq '<>' || $ro eq '~=');
+ $expr = '';
+ if (!numberp($c1) && $c1 =~ /$numvar/) {
+ $c1 = "\$$c1";
+ $expr .= "numberp($c1) && ";
+ }
+ if (!numberp($c2) && $c2 =~ /$numvar/) {
+ $c2 = "\$$c2";
+ $expr .= "numberp($c2) && ";
+ }
+ $expr .= "($c1 $ro $c2)";
+ }
+
+ elsif ($expr =~ /^($comparee)\s*($relop)\s*($comparee)\s*($relop)\s*($comparee)$/) {
+ my($c1) = $1; my($c2) = $3; my($c3) = $5; my($ro1) = $2; my($ro2) = $4;
+ $c1 =~ s/^0*(\d)/\1/; $c2 =~ s/^0*(\d)/\1/; $c3 =~ s/^0*(\d)/\1/;
+ $ro1 = '!=' if ($ro1 eq '<>' || $ro1 eq '~=');
+ $ro2 = '!=' if ($ro2 eq '<>' || $ro2 eq '~=');
+ $expr = '';
+ if (!numberp($c1) && $c1 =~ /$numvar/) {
+ $c1 = "\$$c1";
+ $expr .= "numberp($c1) && ";
+ }
+ if (!numberp($c2) && $c2 =~ /$numvar/) {
+ $c2 = "\$$c2";
+ $expr .= "numberp($c2) && ";
+ }
+ if (!numberp($c3) && $c3 =~ /$numvar/) {
+ $c3 = "\$$c3";
+ $expr .= "numberp($c3) && ";
+ }
+ $expr .= "($c1 $ro1 $c2) && ($c2 $ro2 $c3)";
+ }
+
+ #-----------------------------------
+ # substitute ANTS fields and %PARAMs
+ #-----------------------------------
+ print(STDERR "MID AddrExpr = $expr\n") if ($DEBUG);
+ $expr =~ s{\$%}{%}g; # allow for $%param
+ $expr =~ s{\$\$}{ AnTsDoLlAr }g; # escape
+ while ($expr =~ /\${([^}]*)}/) { # ${field}
+ my($fnr) = cardinalp($1) ? $1-1 : fnr($1);
+ croak("$0: unknown field $1\n") unless ($fnr >= 0);
+ $expr =~ s(\${$1})(AnTsDtArEf\[$fnr\]);
+ }
+ while ($expr =~ /\$([\w\.]+)/) { # $field
+ my($fnr) = cardinalp($1) ? $1-1 : fnr($1);
+ croak("$0: unknown field $1\n") unless ($fnr >= 0);
+ $expr =~ s{\$$1}{AnTsDtArEf\[$fnr\]};
+ }
+ while ($expr =~ /\$\+([\w\.]+)/) { # $+field
+ my($fnr) = cardinalp($1) ? $1-1 : fnr($1);
+ croak("$0: unknown field $1\n") unless ($fnr >= 0);
+ $expr =~ s{\$\+$1}{(AnTsDtArEf\[$fnr\]-AnTsDtArEf0\[$fnr\])};
+ }
+ $expr =~ s{%%}{ AnTsPeRcEnT }g; # escape
+ while ($expr =~ /%([\w\.]+)/) { # %PARAMs
+ my($p) = $1;
+ croak("$0: Undefined PARAM %$p\n")
+ unless defined($P{$p});
+ $expr =~ s{%$p}{\$P\{'$p'\}};
+ }
+ $expr =~ s{AnTsDtArEf}{$bufVar}g;
+ $expr =~ s{ AnTsPeRcEnT} {%}g;
+ $expr =~ s{ AnTsDoLlAr }{\$}g;
+
+ #--------------------
+ # compile and return
+ #--------------------
+QUOTED_ADDR_EXPR:
+ print(STDERR "OUT AddrExpr = $expr\n") if ($DEBUG);
+ my($subR) = eval("sub { return $expr };");
+ print(STDERR "sub { return $expr };\n") if ($DEBUG);
+ croak("sub { return $expr }; => $@\n") if ($@);
+ return $subR;
+}
+
+#----------------------------------------------------------------------
+# Edit Expressions
+# - execute calculation based on and/or modify current record
+# - any valid PERL expression can be an edit expr
+# - $id are assumed to be fields (use $$id for perl vars)
+# - %id are assumed to be PARAMs (use %% to get %)
+# - ${field} are fields
+# - ${field..field} are field ranges
+#----------------------------------------------------------------------
+
+$antsEditExprUsesFields; # flag
+
+sub antsCompileEditExpr($) # subst fields/%PARAMs
+{
+ my($expr,$bufVar) = @_;
+ $bufVar = '$ants_[0]' unless defined($bufVar);
+ $antsEditExprUsesFields = 0;
+
+ print(STDERR "IN EditExpr = $expr\n") if ($DEBUG);
+ goto QUOTED_EDIT_EXPR
+ if ((substr($expr,0,1) eq "'" || substr($expr,0,1) eq '"') &&
+ (substr($expr,0,1) eq substr($expr,-1)));
+
+ $expr =~ s{\$%}{%}g; # allow for $%param
+ $expr =~ s{\$\$}{AnTsDoLlAr}g; # escape
+ while ($expr =~ /\${([^}]*)\.\.([^}]*)}/) { # ${field..field}
+ $antsEditExprUsesFields |= 1;
+ my($ffnr) = cardinalp($1) ? $1-1 : fnr($1);
+ croak("$0: unknown field $1\n") unless ($ffnr >= 0);
+ my($lfnr) = cardinalp($2) ? $2-1 : fnr($2);
+ croak("$0: unknown field $2\n") unless ($lfnr >= 0);
+ croak("$0: empty field range $1..$2\n")
+ unless ($lfnr >= $ffnr);
+ my($expanded) = '';
+ for (my($f)=$ffnr; $f<=$lfnr; $f++) {
+ $expanded .= "AnTsDtArEf[$f]";
+ $expanded .= "," unless ($f == $lfnr);
+ }
+ $expr =~ s(\${$1\.\.$2})($expanded);
+ }
+ while ($expr =~ /\${([^}]*)}/) { # ${field}
+ $antsEditExprUsesFields |= 1;
+ my($fnr) = cardinalp($1) ? $1-1 : fnr($1);
+ croak("$0: unknown field $1\n") unless ($fnr >= 0);
+ $expr =~ s(\${$1})(AnTsDtArEf\[$fnr\]);
+ }
+ while ($expr =~ /\$(-?[\w\.]+)/) { # $field
+ $antsEditExprUsesFields |= 1;
+ my($fnr) = cardinalp($1) ? $1-1 : fnr($1);
+ if ($fnr < 0) { # should only happen on $antsFnrNegativeOk
+ $expr =~ s{\$$1}{AnTsDtArEf\[AnTsDtAlEn$fnr\]};
+ } else {
+ croak("$0: unknown field $1\n") unless ($fnr >= 0);
+ $expr =~ s{\$$1}{AnTsDtArEf\[$fnr\]};
+ }
+ }
+ while ($expr =~ /\$\+([\w\.]+)/) { # $+field
+ $antsEditExprUsesFields |= 1;
+ my($fnr) = cardinalp($1) ? $1-1 : fnr($1);
+ croak("$0: unknown field $1\n") unless ($fnr >= 0);
+ $expr =~ s{\$\+$1}{(AnTsDtArEf\[$fnr\]-AnTsDtArEf0\[$fnr\])};
+ }
+ $expr =~ s{%%}{AnTsPeRcEnT}g; # escape
+ while ($expr =~ /%([\w\.:]+)/) { # %PARAMs
+ my($p) = $1;
+ croak("$0: Undefined PARAM %$p\n")
+ unless defined($P{$p});
+ $expr =~ s{%$p}{\$P\{"$p"\}};
+ }
+ if ($bufVar =~ m{\]$}) {
+ my($adl) = '@{' . $bufVar . '}';
+ $expr =~ s{AnTsDtAlEn}{$adl}g;
+ } else {
+ my($adl) = '@' . substr($bufVar,1);
+ $expr =~ s{AnTsDtAlEn}{$adl}g;
+ }
+ $expr =~ s{AnTsDtArEf}{$bufVar}g;
+ $expr =~ s{AnTsDtArEf}{$bufVar}g;
+ $expr =~ s{AnTsPeRcEnT}{%}g;
+ $expr =~ s{AnTsDoLlAr}{\$}g;
+
+QUOTED_EDIT_EXPR:
+ $expr = "return $expr";
+
+ print(STDERR "OUT EditExpr = $expr\n") if ($DEBUG);
+ my($subR) = eval("sub { $expr };");
+ croak("sub { $expr }; => $@\n") if ($@);
+ return $subR;
+}
+
+#----------------------------------------------------------------------
+# Constant Expressions
+# - carry out calculation based on const and %PARAMs only
+# - same as edit expressions without field substitutions (%PARAMs ok, though)
+# - $ must still be escaped ($$), although this is unlikely to be used ever
+#----------------------------------------------------------------------
+
+sub antsCompileConstExpr($) # subst fields/%PARAMs
+{
+ my($expr) = @_;
+
+ print(STDERR "IN ConstExpr = $expr\n") if ($DEBUG);
+
+ unless ((substr($expr,0,1) eq "'" || substr($expr,0,1) eq '"') &&
+ (substr($expr,0,1) eq substr($expr,-1))) { # quoted string
+ $expr =~ s{\$%}{%}g; # allow for $%param
+ $expr =~ s{\$\$}{AnTsDoLlAr}g; # escape
+ $expr =~ s{%%}{AnTsPeRcEnT}g; # escape
+ while ($expr =~ /%([\w\.:]+)/) { # %PARAMs
+ my($p) = $1;
+ croak("$0: Undefined PARAM %$p\n")
+ unless defined($P{$p});
+ $expr =~ s{%$p}{\$P\{"$p"\}};
+ }
+ $expr =~ s{AnTsPeRcEnT}{%}g;
+ $expr =~ s{AnTsDoLlAr}{\$}g;
+ }
+
+ $expr = "return $expr";
+
+ print(STDERR "OUT ConstExpr = $expr\n") if ($DEBUG);
+ my($subR) = eval("sub { $expr };");
+ croak("sub { $expr }; => $@\n") if ($@);
+ return $subR;
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/antsfilters.pl
@@ -0,0 +1,50 @@
+#======================================================================
+# A N T S F I L T E R S . P L
+# doc: Sun Mar 14 15:17:29 1999
+# dlm: Wed Jan 5 23:34:57 2011
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 15 48 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Mar 14, 1999: - created for filters
+# Dec 11, 1999: - made &antsXCheck() return mean dx
+# - BUG: dx was calculated independently of from val
+# Mar 31, 2004: - added $fac optional param
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+# Jan 5, 2011: - BUG: did not work for -ve dx
+
+# Implement commonly used fuctions for filters (but not worth including
+# into [./antsutils.pl] because of efficiency considerations)
+
+{ my($dx) = 0; # static vars
+
+sub antsXCheck($$$) # ($xfnr,$from,$to,$fac) -> mean dx # sanity check on @ants_
+{
+ my($xfnr,$from,$to,$fac) = @_;
+ my($cdx,$r,$sdx);
+
+ $fac = 2 unless defined($fac);
+
+ unless ($dx) { # find goal dx
+ croak("$0: can't handle nan (x field)\n")
+ unless (numberp($ants_[0][$xfnr]) && numberp($ants_[1][$xfnr]));
+ $dx = $ants_[$from+1][$xfnr] - $ants_[$from][$xfnr];
+ }
+ for ($r=$from+1; $r <= $to; $r++) {
+ croak("$0: can't handle $ants_[$r][$xfnr] (x field)\n")
+ unless (numberp($ants_[$r][$xfnr]));
+ $cdx = $ants_[$r][$xfnr] - $ants_[$r-1][$xfnr];
+ croak("$0: input badly non-uniformly spaced " .
+ "(rec# $r is $ants_[$r][$xfnr]; previous is $ants_[$r-1][$xfnr];" .
+ " target difference is $dx)\n")
+ if (($dx > 0) && ($cdx > $fac*$dx || $cdx < $dx/$fac)) ||
+ (($dx < 0) && ($cdx < $fac*$dx || $cdx > $dx/$fac));
+ $sdx += $cdx;
+ }
+ return $sdx/($to-$from);
+}
+
+} # end of $dx static scope
+
+1;
new file mode 100644
--- /dev/null
+++ b/antsintegrate.pl
@@ -0,0 +1,232 @@
+#!/usr/bin/perl
+#======================================================================
+# A N T S I N T E G R A T E . P L
+# doc: Fri Feb 28 22:54:04 1997
+# dlm: Fri Oct 15 23:14:11 2010
+# (c) 1997 Andreas Thurnherr
+# uE-Info: 27 62 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# Integrator Library; used by [integrate] and [transport]
+# ([transport] is deprecated...)
+
+# HISTORY:
+# Nov 14, 2000: - divorced from [integrate]
+# Nov 16, 2000: - added $opt_i
+# - BUG: $opt_c forgot to output last record
+# - BUG: copying of buffer had not worked
+# Nov 17, 2000: - changed $opt_i to $opt_l
+# Nov 24, 2000: - aimless changes
+# Mar 10, 2002: - added $dx output if $dfnr defined
+# Mar 30, 2002: - cosmetics
+# May 24, 2002: - added -b)ox to -f
+# May 25, 2002: - BUG: -c did not output records with missing y values
+# - changed to dying on missing x values
+# Dec 20, 2005: - BUG: -cf produced short 1st record (dfnr not set)
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+# Oct 15, 2010: - removed warning about integrand set to nan
+
+# NOTES:
+#
+# &integrate() can run in several moments:
+# 0: integral
+# 1: integral weighted by (signed) distance from zero
+# 2: integral weighted by square of distance from zero
+#
+# &integrate() returns the single-value sum; without -f @sum is
+# set as a side-effect
+#
+# unless xmin,xmax are given as args, the integral is taken over the
+# entire data
+#
+# records with missing y values have the integrand(s) set to NaN
+#
+# because this routine was ones an integral part of [integrate] it
+# uses a number of global variables (ug-lee!):
+# $xfnr y = f(x)
+# $opt_c output sum after each step (cummulative)
+# $opt_f integrate only given field
+# $yfnr (if $opt_f) ... this one
+# $opt_b use box rule
+# $iScale (if $opt_f) scale integrated values
+# $opt_l (if $opt_f) output individual summands
+
+sub integrate ($@) # ret integral, set $m
+{
+ my($moment,$zero,$xmin,$xmax) = @_; # optional args
+ my($lastx,$cur,$curwt,$sum,$cury);
+ my($dx,$r,$f,@out,@nan,$warned);
+
+ for ($f=0; $f<$antsBufNFields; $f++) { # prep nan output
+ $nan[$f] = nan;
+ }
+
+ for ($r=0; $r<=$#ants_; $r++) {
+ croak("$0: can't handle non-numeric x values\n")
+ unless (numberp($ants_[$r][$xfnr]));
+
+# 1st, find a valid x value, and a y value on -f (one field only).
+# On -c, generate output: 0 on open limits, nan (only possible
+# if -f is set) otherwise
+
+ unless (defined($lastx)) {
+ if (defined($opt_f)) {
+ if ($opt_c) {
+ @out = @{$ants_[$r]};
+ $out[$yfnr] = numberp($ants_[$r][$yfnr]) ? 0 : nan;
+ $out[$dfnr] = nan if (defined($dfnr));
+ &antsOut(@out);
+ }
+ next unless (numberp($ants_[$r][$yfnr]));
+ $lastx = $ants_[$r][$xfnr];
+ croak("$0: lower limit ($xmin) < first valid x-value ($lastx)\n")
+ if (defined($xmin) && $lastx > $xmin);
+ $lasty = $ants_[$r][$yfnr];
+ next;
+ }
+ $lastx = $ants_[$r][$xfnr];
+ if ($opt_c) {
+ for ($f=0; $f<$antsBufNFields; $f++) {
+ $out[$f] = ($f == $xfnr) ? $ants_[$r][$f] :
+ (numberp($ants_[$r][$f]) ? 0 : nan);
+ }
+ &antsOut(@out);
+ }
+ next;
+ }
+
+# next, update x&y while below lower limit for later interpolation
+# NB: only possible on -f!
+
+ if (defined($xmin) && $ants_[$r][$xfnr] < $xmin) {
+ if (numberp($ants_[$r][$yfnr])) {
+ $lastx = $ants_[$r][$xfnr];
+ $lasty = $ants_[$r][$yfnr];
+ }
+ if ($opt_c) {
+ $ants_[$r][$yfnr] = nan;
+ &antsOut(@{$ants_[$r]});
+ }
+ next;
+ }
+
+# we have an x-value > min; is it valid?
+# NB: xmin is undefined once lower limit is handled
+
+ croak("$0: Error: no data within integration limits\n")
+ if (defined($xmin) && defined($xmax) && $ants_[$r][$xfnr] > $xmax);
+
+# finally! we have a valid x-value; if it's the first, interpolate
+# y at xmin if that's defined
+# undefined xmin at end so this code is not executed again
+# NB: xmin can only be defined on -f!
+
+ if (defined($xmin)) {
+ unless (numberp($ants_[$r][$yfnr])) {
+ if ($opt_c) {
+ $ants_[$r][$yfnr] = nan;
+ &antsOut(@{$ants_[$r]});
+ }
+ next;
+ }
+ $lasty += ($xmin-$lastx) / ($ants_[$r][$xfnr]-$lastx)
+ * ($ants_[$r][$yfnr]-$lasty);
+ $lastx = $xmin; undef($xmin);
+ }
+
+# it is also possible (though not on the first time round), that we
+# have just passed the upper limit (xmax); simulate normal code but
+# using xmax (and interpolated y value) instead of real data
+# NB: xmax can only be defined on -f!
+
+ if (defined($xmax) && $ants_[$r][$xfnr] >= $xmax) {
+ unless (numberp($ants_[$r][$yfnr])) {
+ if ($opt_c) {
+ $ants_[$r][$yfnr] = nan;
+ &antsOut(@{$ants_[$r]});
+ }
+ next;
+ }
+ $dx = $xmax - $lastx;
+ $cury = $lasty + $dx / ($ants_[$r][$xfnr]-$lastx)
+ * ($ants_[$r][$yfnr]-$lasty);
+ croak("$0: x-field must be monotonically increasing [xmax=$xmax, lastx=$lastx]\n")
+ if ($dx < 0);
+ $cur = ($cury+$lasty)/2 * $dx;
+ $cur *= (($xmax+$lastx)/2-$zero)**$moment if ($moment);
+ $sum += $cur*$iScale;
+ if ($opt_c) { # cummulative
+ @out = @{$ants_[$r]}; # copy everything
+ $out[$yfnr] = $sum;
+ $out[$dfnr] = $dx if (defined($dfnr));
+ &antsOut(@out);
+ } elsif ($opt_l) { # individual summands
+ @out = @{$ants_[$r]}; # copy everything
+ $out[$yfnr] = $cur*$iScale;
+ $out[$dfnr] = $dx if (defined($dfnr));
+ &antsOut(@out);
+ }
+ $lastx = $ants_[$r][$xfnr];
+ last;
+ }
+
+# phoar! we are finally handling the normal case
+
+ $dx = $ants_[$r][$xfnr] - $lastx; # calc dx
+ croak("$0: x-field must be monotonically increasing [curx=$ants_[$r][$xfnr], lastx=$lastx]\n")
+ if ($dx < 0);
+
+ if (defined($opt_f)) { # integrate single field
+ unless (numberp($ants_[$r][$yfnr])) {
+ if ($opt_c) {
+ $ants_[$r][$yfnr] = nan;
+ &antsOut(@{$ants_[$r]});
+ }
+ next;
+ }
+ $cur = $opt_b ?
+ $ants_[$r][$yfnr] * $dx : # box rule
+ ($ants_[$r][$yfnr]+$lasty)/2 * $dx; # interpolate
+ $cur *= (($ants_[$r][$xfnr]+$lastx)/2-$zero)**$moment
+ if ($moment);
+ $sum += $cur*$iScale;
+ $lasty = $ants_[$r][$yfnr];
+ if ($opt_c) { # cummulative
+ @out = @{$ants_[$r]}; # copy everything
+ $out[$yfnr] = $sum;
+ } elsif ($opt_l) { # individual summands
+ @out = @{$ants_[$r]}; # copy everything
+ $out[$yfnr] = $cur*$iScale;
+ }
+ } else { # integrate all
+ for ($f=0; $f<$antsBufNFields; $f++) {
+ next if ($f == $xfnr); # except x-field
+ if (numberp($ants_[$r][$f])) { # val found
+ $sum[$f] += $ants_[$r][$f] * $dx # box-rule (no interp)
+ unless isnan($sum[$f]); # had missing vals
+ } else { # val missing
+ $sum[$f] = nan; # mark for later
+# unless ($warned) { # warn user
+# &antsInfo("Warning: integrand(s) set to nan due to missing vals");
+# $warned = 1;
+# }
+ }
+ $out[$f] = $sum[$f] if ($opt_c);
+ }
+ }
+ if ($opt_c || $opt_l) {
+ $out[$xfnr] = $ants_[$r][$xfnr];
+ $out[$dfnr] = $dx if (defined($dfnr));
+ &antsOut(@out);
+ }
+ $lastx = $ants_[$r][$xfnr]; # last good x
+ }
+ croak("$0: empty input!\n") # never initialized
+ unless (defined($lastx));
+ croak("$0: upper limit > last valid x-value!\n")
+ if (defined($xmax) && $xmax>$lastx);
+
+ return $sum;
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/antsio.pl
@@ -0,0 +1,918 @@
+#!/usr/bin/perl
+#======================================================================
+# A N T S I O . P L
+# doc: Fri Jun 19 19:22:51 1998
+# dlm: Thu Apr 26 09:01:50 2012
+# (c) 1998 A.M. Thurnherr
+# uE-Info: 200 107 NIL 0 0 70 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Jun 19, 1998: - created
+# Dec 29, 1998: - added antsLineFlag and antsLinePrefix
+# Dec 30, 1998: - added -P)assthrough option handling, arg to &antsFlush()
+# Jan 02, 1999: - changed -P to -T and added -P)refix for [./fnr]
+# Feb 17, 1999: - added &antsReadFile()
+# Feb 25, 1999: - added &antsInfo()
+# Mar 11, 1999: - set undefined ret-vals of &antsBufOut() to NaN
+# Mar 12, 1999: - added FILE to &antsPrintHeaders()
+# Mar 14, 1999: - BUG ensured that $ants_[0] was defined when
+# typical &antsBufFull was called on empty buffer
+# - added &antsPostFlush()
+# - added &antsSetR_()
+# - BUG padding by &antsSet_() was broken
+# Mar 20, 1999: - added code to abort if file on cmdline does not exist
+# - removed &antsReadFile()
+# Oct 31, 1999: - BUG when using -I
+# Dec 06, 1999: - made &antsInfo() respect -Q
+# Mar 07, 2000: - adapted to -M
+# Jul 31, 2000: - removed buffer auto growth unless $antsPadOut
+# Aug 21, 2000: - allow for in-line comments on -T
+# Aug 28, 2000: - added opt_Z to remove leading zeroes on output
+# - added %P handling
+# Sep 03, 2000: - documentation
+# Sep 04, 2000: - ensure %PARAMS are not just whitespace strings
+# Oct 31, 2000: - added &antsReplaceParam()
+# Nov 07, 2000: - added &antsFileScanParam()
+# Nov 10, 2000: - made to ignore DOS EOF (BLOERKS!!!)
+# Nov 16, 2000: - added comment about antsIO() bypassing &antsBufOut()
+# Nov 17, 2000: - made -P override header PARAMs
+# Jan 16, 2001: - cosmetics
+# Feb 19, 2001: - added $antsNoHeaderCopy for [data]
+# Mar 8, 2001: - adapted to -G)range
+# Mar 18, 2001: - BUG: -G had selected NaNs
+# Mar 22, 2001: - added $antsNoEmbeddedHeaderCopy for [fields] [efields]
+# Mar 28, 2001: - mark header info of utils used in pipelines
+# Mar 31, 2001: - updated -G)range
+# - adapted to -F)ields
+# Apr 3, 2001: - added appendfields
+# Apr 5, 2001: - removed string interpolation from &antsOut()
+# - added prependfields
+# May 15, 2001: - output NaN on undefined -F vals
+# Jun 4, 2001: - allowd %PARAMs on -F
+# Jun 19, 2001: - added pseudo param %FILE
+# Jul 9, 2001: - added Active ANTS stuff
+# Jul 10, 2001: - continued, split off &antsParseHeader()
+# Jul 11, 2001: - continued
+# Jul 13, 2001: - replace -F fields names on 1st use
+# Jul 16, 2001: - moved fchmod call to &antsPrintHeaders(), c.f. [Split]
+# Jul 19, 2001: - embedded error messages in pipeline
+# - copy header on -ve -H
+# Jul 24, 2001: - BUG: set $antsNewLayout on -F
+# - BUG: remove % from -F layout
+# - moved fnr lookup for -G from [antsusage.pl]
+# Aug 1, 2001: - BUG: &antsIn() had not restored @ARGV on EOF
+# Aug 3, 2001: - added &antsFileScanLayout()
+# Aug 9, 2001: - BUG: $antsNewLayout was not set on prepend/append fields
+# Aug 10, 2001: - added $opt_G to &antsFileIn()
+# Aug 19, 2001: - BUG: &antsReplaceParam() re-written
+# Aug 29, 2001: - BUG: made -r into -f && -r
+# Oct 28, 2001: - BUG: handled antsLinePrefix on parseHeader
+# Nov 22, 2001: - added $antsParseHeader flag
+# Nov 28, 2001: - allowed %param in -G
+# Dec 30, 2001: - added &antsExit()
+# May 18, 2002: - added %BASENAME, %EXTN
+# May 20, 2002: - added $antsNewFile
+# Jun 22, 2002: - added $antsPadIn
+# Jan 6, 2003: - added $antsGrex (-G regex support)
+# Jan 8, 2003: - added &antsFileParams()
+# Mar 4, 2003: - added %RECNO
+# Apr 14, 2003: - BUG: antsReplaceParam() removed because in-stream
+# %PARAMs are not generally handled correctly
+# - BUG: antsFileScanParam() had returned the first
+# value encountered, NOT the valid (last) one!!!
+# Apr 24, 2003: - BUG: added default $antsPadIn = 1 (required for
+# [gamma_n])
+# May 8, 2003: - made antsFileIn() respect -N (for [gshear])
+# Jul 1, 2004: - BUG: $antsBufNFields was not set when an empty file
+# with valid #ANTS#FIELDS# was read
+# Jul 9, 2004: - BUG: test of incompatible in-file field definitions
+# did not work
+# Dec 5, 2004: - BUG: Jul 1 fix did not work correctly in cases where
+# subsequent #ANTS#FIELDS# lines would shrink the
+# number of fields; new fix was not debugged!
+# Jan 17, 2005: - removed path from active files and used perl -S
+# Feb 8, 2005: - made activation-status copy more portable (i.e.
+# independent of perl path)
+# Mar 7, 2005: - added %DIRNAME (& cleaned up %BASENAME %EXTN)
+# Nov 8, 2005: - changed -T to -P, -Z => -T, added -Z
+# Nov 17, 2005: - BUG: antsPreFlush() flushed one too few ([fmedian])
+# - BUG: antsFlagged was not set correctly any more
+# Nov 18, 2005: - finally allowed %PARAMs bounds in -G
+# Nov 21, 2005: - BUG: %PARAM bounds in -G had broken regexp capability
+# Dec 7, 2005: - BUG: embedded layout overrode @antsFName if $antsNewLayout
+# - replaced @antsFName by @antsLayout{In,Out}
+# Dec 8, 2005: - Version 3.2 (see [HISTORY])
+# Dec 12, 2005: - disable output padding in &antsOut() if new layout
+# Dec 14, 2005: - made &antsAddParams() set %P
+# - removed &antsReplaceParam()
+# Dec 20, 2005: - BUG: empty field names in Layout replaced by undef
+# - $# is buggy => implemented opt_M without $#
+# Dec 23, 2005: - replaced defined(@array) (c.f. perlfunc(1))
+# - BUG: -F did not work ok when @antsNewLayout was set
+# Dec 29, 2005: - added $PARAMSonly to avoid output duplication on -F%param
+# Dec 30, 2005: - changed &antsFileIn() EOF return
+# Jan 3, 2006: - BUG: pseudo %PARAMs (e.g. BASENAME) were not set
+# on EOF when buffer is not full
+# - changed %FILE to %FILENAME
+# - added support for -S)elect
+# Jan 4, 2006: - BUG: empty strings were not output as NaN
+# Jan 9, 2006: - removed line flagging code
+# Jan 12, 2006: - replaced old -H)eader skip support with new -H)ead
+# Jan 13, 2006: - new [antsexprs.pl]
+# - removed -G handling (now done as -S)
+# - renamed -T)rim to -C)anonical
+# - removed -Z)ap handling
+# Jan 14, 2006: - continued removing -G
+# Jan 31, 2006: - BUG: selecting last field per record with -I produced
+# an extraneous empty line
+# May 18, 2006: - BUG: set pseudo-params before -S test, to allow e.g.
+# -S %RECNO==3 to work
+# - BUG: set %RECNO on partially full buffer
+# - added %LINENO pseudo param
+# Jun 27, 2006: - BUG: added formal param @ to allow antsOut(NaN) to be
+# used in list -w
+# - changed semantics of antsPadOut()
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+# Jul 10, 2006: - removed fchmod (now in perl chmod)
+# Jul 21, 2006: - removed obsolete code
+# Jul 22, 2006: - shuffled &antsOut() to allow for -H0
+# Jul 23, 2006: - BUG: -F%PARAM did not work any more
+# Jul 28, 2006: - BUG: pseudo-params were set during header parsing of
+# an empty file
+# Jul 31, 2006: - BUG: @antsLayout was not set on 0-record files
+# - code cleanup
+# Aug 24, 2006: - added $antsIgnoreInputParams
+# Aug 28, 2006: - made antsIgnoreInputParams into eva'ed expr for [bindata]
+# Oct 26, 2006: - allowed for empty lines in &antsFileScanParams()
+# Nov 10, 2006: - suppressed copying of layout even if embedded headers
+# are copied
+# Dec 17, 2007: - modified behavior of antsIgnoreInputParams (see NOTES below)
+# Jan 16, 2007: - re-implemented changes to -P mandated by Dec 14, 2006
+# changes to [antsusage.pl]
+# May 31, 2007: - added support for -G)eographic coord format
+# Nov 14, 2007: - maded -G work with %PARAMS
+# - BUG: %FILENAME (& others) not set on %PARAMS-only files
+# Nov 15, 2007: - BUG: -G had never worked correctly when selecting fields
+# Feb 8, 2008: - moved number output formatting to fmtNum() [antsutils.pl]
+# Mar 26, 2008: - modified/extended -F behavior
+# Mar 28, 2008: - fiddled
+# Apr 15, 2008: - BUG: pseudo params were not set during header parsing
+# => e.g. %RECNO could not be used in ded addr-expr
+# May 1, 2008: - BUG: embedded header copy also copied embedded layout
+# re-definitions
+# May 22, 2008: - BUG: $antsPadOut = 0 did not suppress padding as intended
+# in presence of layout or new layout => add option of
+# setting it to -1
+# Jul 11, 2008: - BUG: file-name-related pseudo %PARAMs did not work
+# correctly for input files without extensions
+# - added %FILENAME -> %PATHNAME
+# Jul 21, 2008: - fiddled with antsInfo()
+# Jul 23, 2008: - added code to allow deleting %PARAMs by setting them
+# to undef in [list]
+# Jul 29, 2008: - BUG: removed code to strip leading/trailing spaces from
+# %PARAMs (before, a %PARAM containing just spaces
+# was deleted on an NCode/listNC combo --- there is
+# an example in [ubtest/NCode.TF]
+# Jun 10, 2009: - added duplicate-output-field sanity check
+# Aug 1, 2009: - BUG: duplicate unnamed output files generated error
+# Aug 23, 2009: - V4.0: added &antsAddDeps
+# Aug 25, 2009: - BUG: '-' was added as a dep for STDIN
+# Aug 27, 2009: - added pseudo %PARAM %DEPS
+# Oct 3, 2009: - added $antsAllowEmbeddedLayoutChange
+# Oct 12, 2009: - changed antsAddDeps() to ignore empty dependencies
+# Oct 13, 2009: - removed antsAddDeps() defaults
+# Oct 15, 2009: - replaced \n by \\n in antsAddParams(); primarily for listNC
+# Nov 3, 2009: - BUG: <> dependencies were not set when $antsParseHeader was set to 0
+# Nov 6, 2009: - BUG: stdin had sometimes produced empty dep
+# Aug 15, 2010: - turned error on duplicate output fields into warning
+# Aug 28, 2010: - moved dependency checks from [list] to here
+# Oct 18, 2010: - disabled dependency checks for files in other directories
+# Oct 19, 2010: - implemented &antsOut('EOF') to clear all static vars & other stuff to
+# allow a single utility to output different ANTS files (used in
+# LADCPproc)
+# Apr 28, 2011: - added code to make all nans lowercase to antsIn()
+# May 20, 2011: - BUG: %LINENO had not been reset between files any more
+# May 22, 2011: - adapted to new antsCompileEditExpr()
+# May 24: 2011: - BUG: forgot '$' in a variable (where???)
+# Jul 28, 2011: - disabled adding of new deps on -D
+# Apr 11, 2012: - improved layout-change error message
+# Apr 26, 2012: - BUG: antsFileScanParam() was not properly anchored (%start_date matched %BT.start_date)
+
+# NOTES:
+# - %P was named without an ants-prefix because associative arrays
+# are rare (and perl supports multiple name spaces for the
+# different variable types) and to facilitate its use in
+# [list]
+# - copying of embedded (i.e. not appearing at start) headers is
+# required e.g. for subsample -i ... | list %some-param
+
+# $antsIngoreInputParams:
+# - is eval'ed first time antsIn() is called (usually while parsing header)
+# - if it evaluates to TRUE, all input %PARAMS are ignored (even if it would
+# later eval to FALSE)
+# - during header parsing, @ARGV only contains additional file arguments,
+# i.e. setting $antsIgnoreInputParams = '@ARGV>0' before antsUsage() is
+# called ignores all input %PARAMs if there is more than 1 file argument
+
+#======================================================================
+# Default Behaviour
+#======================================================================
+
+# Flags
+
+$antsPadIn = 1; # fill with nan on input
+$antsFixedFormat = 0; # remove leading & trailing stuff
+$antsParseHeader = 1; # parse header on &antsUsage()
+$antsIgnoreInputParams = 0; # ignore %PARAMs
+$antsAllowEmbeddedLayoutChange = 0; # disallow layount changes
+
+# Standard Fixed Size Buffer
+
+sub antsBufFull() # default buffer full
+ {return $#ants_+1 == $antsBufSize;}
+sub antsBufOut($) # default constructor
+ {return $ants_[$ants_][$_[0]]; }
+
+# Setup Size 1 Buffer
+
+$antsBufSize = 1; # default
+$antsBufSkip = 1;
+
+#======================================================================
+# Interface
+#======================================================================
+
+sub antsInstallBufFull($)
+{
+ eval "sub antsBufFull() { $_[0] }";
+ croak($@) if ($@);
+ &antsReCompile();
+}
+
+sub antsInstallBufOut($)
+{
+ eval "sub antsBufOut(\$) { my(\$fnr)=\@_; $_[0] }";
+ croak($@) if ($@);
+ &antsReCompile();
+}
+
+sub antsActivateOut()
+{
+ $antsActiveHeader = "#!/usr/bin/perl -S list\n" unless ($opt_Q);
+}
+
+#----------------------------------------------------------------------
+# antsCheckDeps([filename]):
+# - call only after header has been parsed
+# - by default, tests current <> file
+#----------------------------------------------------------------------
+
+{ my($warned);
+
+ sub antsCheckDeps()
+ {
+ my($infile) = @_ ? $_[0] : $ARGV; # default: check current input
+ my($indir) = ($infile =~ m{^(.*)/[^/]*$});
+# print(STDERR "checking dependencies of file $infile (deps = @antsDeps)\n");
+
+ return if ($opt_D); # suppress
+ return unless (@antsDeps); # no dependency info
+ return if defined($indir) && $indir ne '.'; # not in current directory
+
+ my(@stat) = stat($infile); # get time
+ return unless (@stat); # happens on stdin?
+
+ my($ctimef) = 10; my($ctime) = $stat[$ctimef];
+ for (my($d)=0; $d<=$#antsDeps; $d++) {
+ @stat = stat($antsDeps[$d]);
+ if (@stat) {
+ croak("$0: <$infile> is stale with respect to <$antsDeps[$d]>\n")
+ unless ($stat[$ctimef] <= $ctime);
+ } elsif (!$warned) {
+ &antsInfo("WARNING: dependency $antsDeps[$d] (&, possibly, others) not found");
+ $warned = 1;
+ }
+ }
+ }
+} # static scope
+
+sub antsParseHeader()
+{
+ return if ($antsFixedFormat || !$antsParseHeader);
+ $antsDoParseHeader = 1; # glorks!
+ my($success) = &antsIn();
+ &antsCheckDeps();
+ return $success;
+}
+
+#----------------------------------------------------------------------
+
+sub antsReCompile() # re-compile with funs
+{ eval '
+
+sub antsIn()
+{
+ my(@Layout);
+ undef(@Layout); # needed, but unclear why
+
+ undef($antsNewFile); # assume no new file
+
+ unless ($antsHeaderParsed || $antsDoParseHeader) {
+ for (my($i)=0; $i<=$#ARGV; $i++) { # check file params
+ open($ARGV[$i]),croak("$0: $ARGV[$i]: $!\n")
+ unless (-f $ARGV[$i] && -r $ARGV[$i]);
+ }
+ &antsAddDeps($ARGV,@ARGV); # <> files
+ $antsCurHeader =~ s/\]/\] |/ # mark as pipeline
+ unless (-t 0);
+ $antsHeaderParsed = 1;
+ }
+
+ my(@tempARGV); # temporily remove non-file args
+ if ($antsDoParseHeader) {
+ my($ai) = $#ARGV;
+ while ($ai >= 0 && -f $ARGV[$ai]) { $ai-- }
+# print(STDERR "before: @ARGV\n");
+ push(@tempARGV,splice(@ARGV,0,$ai+1));
+# print(STDERR "after: @ARGV\n");
+ if ($#ARGV < 0 && -t 0) { # donot wait on stdin
+ push(@ARGV,@tempARGV);
+ $antsDoParseHeader=0;
+ return 0;
+ }
+ }
+
+ splice(@ants_,0,$antsBufSkip); # shift buffers
+
+ IN: until ($#ants_>=0 && &antsBufFull()) { # fill buffer; NEEDS RECOMPILE
+
+ if (defined($antsPeekBuffer)) { # from header parsing
+ $_ = $antsPeekBuffer;
+ $antsPeekBuffer = undef;
+ } else {
+ unless ($_ = <>) { # get next record
+ # EOF before buffer is full (can be partially filled)
+ unshift(@ARGV,@tempARGV); # restore ARGV list
+
+ @antsLayout = @Layout if (@Layout); # set last defined layout
+ $antsBufNFields = @antsLayout # adjust buffer width
+ if (@antsLayout > $antsBufNFields);
+
+ my($lastFile) = $P{PATHNAME};
+ $P{PATHNAME} = $ARGV; # set pseudo %PARAMs
+ ($P{DIRNAME},$P{FILENAME}) =
+ ($ARGV =~ m{^(.*)/([^/]+)$});
+ unless (defined($P{DIRNAME})) {
+ $P{DIRNAME} = ".";
+ $P{FILENAME} = $P{PATHNAME};
+ }
+ ($P{BASENAME},$P{EXTN}) =
+ ($P{FILENAME} =~ m{^([^\.]+)\.(.+)$});
+ unless (defined($P{EXTN})) {
+ $P{BASENAME} = $P{FILENAME};
+ $P{EXTN} = "";
+ }
+ $P{DEPS} = "@antsDeps";
+
+ return 0 if ($antsDoParseHeader); # empty file!!!
+
+ $P{RECNO} = -1 # set pseudo %PARAMs
+ unless defined($P{RECNO});
+ $P{RECNO}++;
+ $P{LINENO} = ($ARGV eq $lastFile) ? $P{LINENO}+1 : 0;
+
+ return 0; # return EOF
+ }
+ }
+
+ next IN if (length == 1 && ord == 26); # handle MS-DOG EOF
+
+ &antsActivateOut(),next IN # copy activation status
+ if (m{^#![^\s]*/perl\s.*list$});
+
+ exit(1) if (/^#ANTS#ERROR#/); # error in pipeline
+
+ if (/^#ANTS#PARAMS# ([^\{]+)\{([^\}]*)\}/) {
+ if (eval($antsIgnoreInputParams)) { # eval only 1st time
+ $antsIgnoreInputParams = 1;
+ next IN;
+ }
+ do {
+ if ($2 eq "") {
+ delete($P{$1});
+ } else {
+ $P{$1} = $2;
+ }
+ } while ($\' =~ m/ ([^\{]+)\{([^\}]*)\}/);
+ } elsif (/^#ANTS#DEPS# \{([^\}]*)\}/) { # handle dependencies
+ do { push(@antsDeps,$1); }
+ while ($\' =~ m/ \{([^\}]*)\}/);
+ } elsif (/^#ANTS# \[[^\]]*\] [^|]/) { # pipe-head => restart dependencies
+ undef(@antsDeps);
+ } elsif (/^#ANTS#FIELDS# \{([^\}]*)\}/) { # handle layout
+ undef(@Layout);
+ do {
+ push(@Layout,$1 eq "" ? undef : $1);
+ } while ($\' =~ m/ \{([^\}]*)\}/);
+ }
+
+ if (!($opt_Q || $antsNoHeaderCopy) && /^#ANTS#/) { # handle headers
+ if (defined($antsHeadersPrinted)) { # embedded headers
+# The following is somewhat subtle because it must prevent embedded
+# layout definitions to be copied 1) even if embedded headers are requested
+# (because otherwise there will be embedded-layout-change errors) 2) but not
+# if there has not been a layout defined already (ubtest common_opts);
+ print unless ($antsNoEmbeddedHeaderCopy ||
+ (/^#ANTS#FIELDS#/ && @antsLayout));
+ } else {
+ $antsOldHeaders .= $_;
+ }
+ next IN;
+ }
+
+ if (/^#/) { # handle non-header comments
+ &antsPrintHeaders(STDOUT,@antsNewLayout),print if ($opt_P);
+ next IN;
+ }
+
+ next IN if /^\s*$/; # skip empty lines
+ unless ($antsFixedFormat) {
+ s/^\s+//; # strip leading space
+ s/#.*$// unless ($opt_P); # strip trailing comments
+ s/\s+$//; # strip trailing space
+ }
+
+ # DONE WITH HEADER PARSING
+
+ croak("$0: embedded layout change when reading file $ARGV <@antsLayout> -> <@Layout>")
+ if (!$antsAllowEmbeddedLayoutChange && @Layout && @antsLayout && ("@Layout" ne "@antsLayout"));
+
+ @antsLayout = @Layout unless (@antsLayout);
+
+ $P{RECNO} = -1 unless defined($P{RECNO}); # set pseudo %PARAMs
+ $P{LINENO} = -1 unless defined($P{LINENO});
+ $P{DEPS} = "@antsDeps";
+
+ my($lastFile) = $P{PATHNAME};
+ $P{PATHNAME} = $ARGV;
+ ($P{DIRNAME},$P{FILENAME}) =
+ ($ARGV =~ m{^(.*)/([^/]+)$});
+ unless (defined($P{DIRNAME})) {
+ $P{DIRNAME} = ".";
+ $P{FILENAME} = $P{PATHNAME};
+ }
+ ($P{BASENAME},$P{EXTN}) =
+ ($P{FILENAME} =~ m{^([^\.]+)\.(.+)$});
+ unless (defined($P{EXTN})) {
+ $P{BASENAME} = $P{FILENAME};
+ $P{EXTN} = "";
+ }
+
+ if ($antsDoParseHeader) { # done parsing
+ unshift(@ARGV,@tempARGV);
+ $antsDoParseHeader = undef;
+ $antsPeekBuffer = $_;
+ $antsPadOut = $antsBufNFields = split($opt_I,$antsPeekBuffer);
+ return 1;
+ }
+
+ $P{RECNO}++; # update pseudo %PARAMs
+ $P{LINENO} = ($ARGV eq $lastFile) ? $P{LINENO}+1 : 0;
+
+ s/[Nn][Aa][Nn]/nan/g; # make all nans lower case
+
+ local(@in) = split($opt_I); # needs to be local for -S
+ if (defined($opt_S)) { # -S)elect
+ $opt_S = &antsCompileAddrExpr($opt_S,\'$in\')
+ unless ref($opt_S);
+ next IN unless (&$opt_S);
+ }
+
+ if (@antsNFNames) { # -N)ums
+ for (my($i)=0; $i<=$#antsNFNames; $i++) {
+ unless (defined($antsNfnr[$i])) {
+ if ($antsNFNames[$i] =~ /^%/) {
+ croak("$0: illegal -N option ($antsNFNames[$i] undefined)\n")
+ unless (defined($P{$\'}));
+ next IN unless (numberp($P{$\'}));
+ } else {
+ $antsNfnr[$i] = &fnr($antsNFNames[$i]);
+ next IN unless (numberp($in[$antsNfnr[$i]]));
+ }
+ } else {
+ next IN unless (numberp($in[$antsNfnr[$i]]));
+ }
+ }
+ }
+
+ chomp;
+ $antsLineBuf = $_; # save
+
+ push(@ants_,[@in]); # add to buffer
+
+ if ($#{$ants_[$#ants_]}+1 > $antsBufNFields) { # grow # of fields
+ $antsBufNFields = $#{$ants_[$#ants_]} + 1;
+# print("antsBufNFields := $antsBufNFields --- $_");
+ if ($antsPadIn) {
+ for ($i=0; $i<$#ants_; $i++) {
+ push(@{$ants_[$i]},nan)
+ while ($#{$ants_[$i]}+1 < $antsBufNFields);
+ }
+ }
+ }
+ push(@{$ants_[$#ants_]},nan) # pad this
+ while ($antsPadIn && $#{$ants_[$#ants_]}+1 < $antsBufNFields);
+ }
+
+ $ants_ = ($#ants_ - $#ants_%2) / 2; # set current idx to centre
+# print(STDERR "reading done; $#ants_+1 recs in buf, $ants_ is cur\n");
+
+ if ($antsLastFileName ne $ARGV) { # signal new file
+ $antsLastFileName = $ARGV;
+ $antsNewFile = 1;
+ }
+
+ return $#ants_+1; # ok
+}
+
+#----------------------------------------------------------------------
+
+{ my(@ofn); # output layout # STATIC SCOPE
+ my(@OEparam); # -F %PARAMs
+ my(@OEfield); # -F fields
+ my(@OEexpr); # -F exprs (compiled)
+ my($EOparamsOnly); # nothing but %PARAMs in -F
+
+ sub antsOut(@)
+ {
+ my(@out) = @_;
+ if (@out == 1 && $out[0] eq "EOF") {
+ undef(@ofn); undef(@OEparam); undef(@OEfield); undef(@OEexpr); undef($EOparamsOnly);
+ undef($antsHeadersPrinted); undef(@antsOutExprs);
+ $antsPadOut = $antsBufNFields = @antsNewLayout; # NB: MUST BE SET BEFORE &antsOut("EOF");
+ return;
+ }
+
+ # STEP 0: PREPARE STUFF
+
+ @ofn = @antsNewLayout unless (@ofn); # output layout
+ @ofn = @antsLayout unless (@ofn);
+
+ # STEP 1: CONSTRUCT @out IF NEEDED
+
+ unless (@out > 0) {
+ for (my($fnr)=0; $fnr<$antsBufNFields; $fnr++) {
+ $out[$fnr] = &antsBufOut($fnr); # calc; NEEDS RECOMPILE
+ }
+ }
+
+ # STEP 2: HANDLE FIELD SELECTION (-F)
+
+ if (@antsOutExprs) {
+
+ unless ($antsOutExprsCompiled) { # parse/compile
+ my(@ofn_buf) = @ofn; # save current output layout
+ undef(@ofn);
+
+ $OEparamsOnly = 1;
+ for (my($if)=my($of)=0; $if<@antsOutExprs; $if++,$of++) {
+ if ($antsOutExprs[$if] =~ m{^%([\w\.]+)$}) { # %PARAM
+ $ofn[$of] = $1;
+ $OEparam[$of] = 1;
+ } elsif ($antsOutExprs[$if] =~ m{^[\w\.]+$}) { # single field
+ undef($OEparamsOnly);
+ $ofn[$of] = $antsOutExprs[$if];
+ $OEfield[$of] = &outFnr($antsOutExprs[$if]);
+ } elsif ($antsOutExprs[$if] eq \'$@\') { # all fields
+ undef($OEparamsOnly);
+ for (my($i)=0; $i<@ofn_buf; $i++,$of++) {
+ $ofn[$of] = $ofn_buf[$i];
+ $OEfield[$of] = $i;
+ }
+ } else { # expression
+ undef($OEparamsOnly);
+ my($expr);
+ ($ofn[$of],$expr) = ($antsOutExprs[$if] =~ m{^([\w\.]*)=(.*)$});
+ croak("$0: cannot parse -F $antsOutExprs[$if]\n")
+ unless defined($expr);
+ my(@tmp) = @antsLayout;
+ @antsLayout = @ofn_buf;
+ $OEexpr[$of] = &antsCompileEditExpr($expr,\'$out_buf\');
+ @antsLayout = @tmp;
+ }
+ }
+ $antsOutExprsCompiled = 1;
+ }
+
+ local(@out_buf) = @out; # save current output data
+ undef(@out); # accessible from within exprs
+
+ for (my($f)=0; $f<@ofn; $f++) { # create @out according to -F
+ if ($OEparam[$f]) {
+ $out[$f] = $P{$ofn[$f]};
+ } elsif (defined($OEfield[$f])) {
+ $out[$f] = $out_buf[$OEfield[$f]];
+ } else {
+ $out[$f] = &{$OEexpr[$f]};
+ }
+ }
+ }
+
+ # STEP 3: PRINT HEADERS
+
+ if (@antsNewLayout || @antsOutExprs) {
+ &antsPrintHeaders(STDOUT,@ofn);
+ } else {
+ &antsPrintHeaders(STDOUT);
+ }
+
+
+ # STEP 4: DONE, DUE TO -H RUNNING OUT
+
+ &antsExit() if (defined($opt_H) && ($opt_H-- == 0));
+
+
+ # STEP 5: PRINT DATA
+
+ $antsPadOut = @ofn if ($antsPadOut >= 0 && @ofn);
+ push(@out,nan) while (@out < $antsPadOut);
+
+ my($outStr);
+ for (my($fnr)=0; $fnr<=$#out; $fnr++) {
+ $out[$fnr] =
+ fmtNum($out[$fnr],
+ @antsNewLayout ? $antsNewLayout[$fnr] : $antsLayout[$fnr]);
+ $outStr .= (defined($out[$fnr]) && $out[$fnr] ne "" ? $out[$fnr] : nan)
+ . ($fnr == $#out ? $opt_R : $opt_O);
+ }
+ print($outStr);
+
+ # STEP 6: DONE, DUE TO -F WITH PARAMS ONLY
+
+ &antsExit() if ($OEparamsOnly);
+
+ } # antsOut()
+} # STATIC SCOPE
+
+#----------------------------------------------------------------------
+
+sub antsIO() # combine input and output
+{ # NB: BYPASSES &antsBufOut()!
+ my($i);
+ for ($i=0; $i<$antsBufSkip && $i<=$#ants_; $i++) {
+ &antsOut(@{$ants_[$i]});
+ }
+ return &antsIn(); # re-fill
+}
+
+sub antsPreFlush() # pre-flush buffer to cur
+{
+ my($i);
+ for ($i=0; $i<=$ants_; $i++) {
+ &antsOut(@{$ants_[$i]});
+ }
+}
+
+sub antsPostFlush() # post-flush buffer after cur
+{
+ my($i);
+ for ($i=$ants_; $i<=$#ants_; $i++) {
+ &antsOut(@{$ants_[$i]});
+ }
+}
+
+sub antsFlush() # flush buffer
+{
+ &antsOut(@{$ants_[0]}),shift(@ants_)
+ while ($#ants_ >= 0);
+}'; die("antsReCompile: $@\n") if ($@); # re-compile functions
+
+} # of antsReCompile()
+
+&antsReCompile(); # compile
+
+#----------------------------------------------------------------------
+
+sub antsSetR_($$$) # set field in any rec
+{ my($r,$f,$v) = @_;
+ $antsBufNFields = $f+1 # auto extension
+ if ($antsBufNFields-1 < $f);
+ while ($#{$ants_[$r]} < $f-1) {
+ push(@{$ants_[$r]},nan);
+ }
+ $ants_[$r][$f] = $v;
+}
+
+sub antsSet_($$) # set field in current rec
+{ &antsSetR_($ants_,$_[0],$_[1]); }
+
+#----------------------------------------------------------------------
+
+{ my(%sExprs); # multiple layouts -> multiple compiled -S exprs
+
+sub antsFileIn() # read from a file
+{ my($f) = @_;
+
+ REDO:
+ return () unless ($_ = <$f>); # get next record (return EOF)
+
+ goto REDO if /^#/; # skip comments
+ goto REDO if /^\s*$/; # skip empty lines
+ s/^\s+//; # remove leading spaces
+ s/#.*$//; # remove trailing comments
+
+ local(@in) = split($opt_I); # needs to be local for -S
+
+ if (defined($opt_S)) { # -S)elect
+ $sExprs{$f} = &antsCompileAddrExpr($opt_S,'$in')
+ unless defined($sExprs{$f});
+ goto REDO unless (&{$sExprs{$f}});
+ }
+
+ if (@antsNFNames) { # handle -N)ums
+ for (my($i)=0; $i<=$#antsNFNames; $i++) {
+ if ($antsNFNames[$i] =~ /^%/) {
+ croak("$0: illegal -N option ($antsNFNames[$i] undefined)\n")
+ unless (defined($P{$'}));
+ goto REDO unless (numberp($P{$'}));
+ } else {
+ $antsNfnr[$i] = &fnr($antsNFNames[$i]);
+ goto REDO unless (numberp($in[$antsNfnr[$i]]));
+ }
+ }
+ }
+
+ return @in;
+}
+
+} # static scope
+
+#======================================================================
+# Utilities
+#======================================================================
+
+sub antsPrintHeaders($@) # handle headers
+{
+ return if ($antsHeadersPrinted); # do only once
+ $antsHeadersPrinted = 1;
+ local(*fh,@newLayout) = @_;
+
+ if (@newLayout) { # check for duplicate field names
+ my(%fn);
+ for (my($i)=0; $i<=$#newLayout; $i++) {
+ next unless defined($newLayout[$i]) && $newLayout[$i] ne '';
+ if ($fn{$newLayout[$i]}) {
+ &antsInfo("duplicate output field <$newLayout[$i]> changed to <$newLayout[$i]_>");
+ $newLayout[$i] .= '_';
+ again;
+ }
+ $fn{$newLayout[$i]} = 1;
+ }
+ }
+
+ return if ($opt_Q); # suppress
+
+ if (defined($antsActiveHeader)) { # activate file
+ chmod(0777&~umask,*fh);
+ print(fh $antsActiveHeader);
+ }
+
+ print(fh $antsOldHeaders); # old headers
+
+ print(fh $antsCurHeader) unless ($opt_X); # new headers
+ print(fh $antsCurParams);
+ print(fh $antsCurDeps) unless ($opt_X);
+ if (@newLayout) {
+ print(fh "#ANTS#FIELDS# ");
+ for (my($i)=0; $i<=$#newLayout; $i++) {
+ print(fh "{$newLayout[$i]} ");
+ }
+ print(fh "\n");
+ }
+
+
+}
+
+sub antsExit()
+{
+ &antsPrintHeaders(STDOUT,@antsNewLayout);
+ exit(0);
+}
+
+#----------------------------------------------------------------------
+
+# NB: to use antsInfo in expressions, a return value of 1
+# has been assumed!!!
+
+sub antsInfo(@) # add info to header & STDERR
+{
+ return 1 if ($opt_Q);
+ my($fmt,@args) = @_; # can't do it directly!!!
+ my($msg) = sprintf($fmt,@args);
+ $antsCurHeader .= "#ANTS# $0: $msg\n";
+ print(STDERR "$0: $msg\n");
+ return 1;
+}
+
+#----------------------------------------------------------------------
+# %PARAM-related stuff
+#----------------------------------------------------------------------
+
+sub antsAddParams(@) # add params
+{
+ my($i);
+
+ $antsCurParams .= "#ANTS#PARAMS#";
+ for ($i=0; $i<$#_; $i+=2) {
+ my($v) = $_[$i+1];
+ $v =~ s/\n/\\n/g;
+ $P{$_[$i]} = $v;
+ $antsCurParams .= " $_[$i]\{$v\}";
+ }
+ $antsCurParams .= "\n";
+}
+
+sub antsFileParams() # get params from file
+{
+ my($f) = @_;
+ my(%P);
+
+ while ($_ = <$f>) { # get next record
+ if (/^#ANTS#PARAMS# ([^\{]+)\{([^\}]*)\}/) {
+ do {
+ $P{$1} = $2;
+ $P{$1} =~ s/^\s*//; # ensure non-null
+ } while ($' =~ m/ ([^\{]+)\{([^\}]*)\}/);
+ }
+ }
+ seek($f,0,0) || croak("$0: $@\n");
+ return %P;
+}
+
+# antsFileScanParam() only scans the 1st header!!!!
+# empty lines are ok, though
+
+sub antsFileScanParam() # find param in file
+{
+ my($f,$pn) = @_;
+ my($val);
+
+ while ($_ = <$f>) { # get next record
+ last unless (/^#/ || /^\s*$/);
+ next unless (/^#ANTS#PARAMS# /);
+ $val = $1 if (/ $pn\{([^\}]*)\}/);
+ }
+ seek($f,0,0) || croak("$0: $@\n");
+ return $val;
+}
+
+#----------------------------------------------------------------------
+# Layout-related stuff
+#----------------------------------------------------------------------
+
+sub antsFileLayout($) # return layout
+{ my($f) = @_;
+ my(@lo);
+
+ while ($_ = <$f>) { # get next record
+ next unless (/^#ANTS#FIELDS# /);
+ @lo = split(' ',$');
+ }
+ seek($f,0,0) || croak("$0: $@\n");
+ for (my($i)=0; $i<=$#lo; $i++) {
+ $lo[$i] =~ s/^\{(.*)\}$/$1/;
+ }
+ return @lo;
+}
+
+sub antsFileScanFnr($$) # find fnr in file
+{ my($f,$fn) = @_;
+ my(@lo) = &antsFileLayout($f);
+
+ for (my($f)=0; $f<=$#lo; $f++) {
+ return $f if ($fn eq $lo[$f]);
+ }
+ return undef;
+}
+
+#----------------------------------------------------------------------
+# Deps-related stuff
+#----------------------------------------------------------------------
+
+sub antsAddDeps(@) # add Deps
+{
+ my(@deps) = @_;
+ return if $opt_D || (@deps==1 && ($deps[0] eq '-' || $deps[0] eq '')); # STDIN
+
+ $antsCurDeps .= '#ANTS#DEPS#';
+ for (my($i)=0; $i<=$#deps; $i++) {
+ next if (length($deps[$i]) == 0);
+ $antsCurDeps .= " \{$deps[$i]\}";
+ }
+ $antsCurDeps .= "\n";
+}
+
+#======================================================================
+
+1;
new file mode 100644
--- /dev/null
+++ b/antsnc.pl
@@ -0,0 +1,301 @@
+#======================================================================
+# A N T S N C . P L
+# doc: Mon Jul 17 11:59:37 2006
+# dlm: Tue Jul 21 21:50:44 2009
+# (c) 2006 A.M. Thurnherr
+# uE-Info: 24 54 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# ANTS netcdf library
+
+# HISTORY:
+# Jul 17, 2006: - created
+# Jul 21, 2006: - documented
+# - added NC-encoding routines
+# Jul 22: 2006: - BUG: pseudo %PARAMs were written as well
+# - BUG: var ATTRs were not enconded correctly
+# - added type support
+# Jul 23, 2006: - improved type magic
+# Sep 1, 2006: - BUG: removing trainling 0s had not worked
+# Sep 23, 2006: - fiddled
+# Jul 11, 2008: - adapted to new pseudo %PARAMs
+# Jul 16, 2008: - remove \0s from strings in NC_stringify
+# Mar 20, 2008: - added progress output to NC_stringify
+# Jul 21, 2009: - allowed for suppression of %PARAMs
+
+# NOTES:
+# - multi-valued attribs are not loaded by getInfo()
+# - spaces in NC strings are replaced by underscores
+# - data filling is disabled, because of a bug in the NetCDF library
+
+# NetCDF Library Bug:
+# The library appears to have incorrect default _FillValue types for
+# integer data types. The error appears if the "setfill" line is commented
+# out and the following command is run:
+# listNC -ct dbk100.nc | NCode -o TEMP.nc time
+# NB: The error occurs when the 1st variable value is written, NOT when
+# the first Q_time value is written. However, when all the Q_ fields
+# are ommitted, the error disappears.
+
+use NetCDF;
+
+#----------------------------------
+# string representation of NC types
+#----------------------------------
+
+sub NC_typeName($)
+{
+ my($tp) = @_;
+
+ return 'byte' if ($tp == NetCDF::BYTE);
+ return 'char' if ($tp == NetCDF::CHAR);
+ return 'short' if ($tp == NetCDF::SHORT);
+ return 'long' if ($tp == NetCDF::LONG);
+ return 'float' if ($tp == NetCDF::FLOAT);
+ return 'double' if ($tp == NetCDF::DOUBLE);
+ croak("$0: unknown NetCDF type #$tp\n");
+}
+
+sub NC_type($)
+{
+ my($tn) = lc($_[0]);
+
+ return NetCDF::BYTE if ($tn eq 'byte');
+ return NetCDF::CHAR if ($tn eq 'char');
+ return NetCDF::SHORT if ($tn eq 'short');
+ return NetCDF::LONG if ($tn eq 'long');
+ return NetCDF::FLOAT if ($tn eq 'float');
+ return NetCDF::DOUBLE if ($tn eq 'double');
+ croak("$0: unknown NetCDF type <$tn>\n");
+}
+
+#--------------------------------------
+# test whether given NC type is numeric
+#--------------------------------------
+
+sub NC_isNumeric($)
+{
+ my($tp) = @_;
+
+ return 1 if ($tp == NetCDF::BYTE);
+ return 1 if ($tp == NetCDF::SHORT);
+ return 1 if ($tp == NetCDF::LONG);
+ return 1 if ($tp == NetCDF::FLOAT);
+ return 1 if ($tp == NetCDF::DOUBLE);
+ return 0;
+}
+
+#----------------------------------------
+# test whether given NC type is character
+#----------------------------------------
+
+sub NC_isChar($)
+{
+ return $_[0] == NetCDF::CHAR;
+}
+
+#-----------------------------------
+# convert character- to string array
+#-----------------------------------
+
+sub NC_stringify($@)
+{
+ my($len,@chars) = @_;
+ my(@strings);
+ my($nStrings) = @chars/$len;
+
+ print(STDERR "$0: extracting $nStrings strings")
+ if ($nStrings > 1000);
+
+ while (@chars) {
+ print(STDERR ".") if ($nStrings>1000 && $n++%1000 == 0);
+ push(@strings,pack("c$len",@chars));
+ $strings[$#strings] =~ s/ /_/g;
+ $strings[$#strings] =~ s/\0//g;
+ splice(@chars,0,$len);
+ }
+ print(STDERR "\n") if ($nStrings > 1000);
+ return @strings;
+}
+
+#----------------------------------------------------------------------
+# open netcdf file and read (most) metadata into hash
+#
+# INPUT:
+# <filename>
+#
+# OUTPUT:
+# $NC{id} netcdf id
+#
+# @NC{attrName}[] names of global attrs
+# %NC{AttrType}{$aName} types of global attrs
+# %NC{AttrLen}{$aName} # of elts in global attrs
+# %NC{Attr}{$aName} vals of scalar global attrs
+#
+# $NC{unlim_dimId} dim id of unlimited dim
+# @NC{dimName}[$dimId] dim names
+# %NC{dimID}{$dName} dim ids
+# %NC{dimLen}{$dName} # elts in dim
+#
+# @NC{varName}[$varId] var names
+# %NC{varType}{$vName} var types
+# %NC{varId}{$vName} var ids
+# @%NC{varDimIDs}{$vName}[] dims of vars, e.g. u(lon,lat)
+# @%NC{varAttrName}{$vName}[] names of var attrs
+# %%NC{varAttrType}{$vName}{$aName} types of var attrs
+# %%NC{varAttrLen}{$vName}{$aName} # of elts in var attrs
+# %%NC{varAttr}{$vName}{$aName} vals of scalar var attrs
+#
+#----------------------------------------------------------------------
+
+sub NC_readMData($)
+{
+ my($fn) = @_;
+ my(%NC);
+
+ $NC{id} = NetCDF::open($ARGV[0],NetCDF::NOWRITE); # open
+
+ my($nd,$nv,$nga,$udi); # get nelts
+ NetCDF::inquire($NC{id},$nd,$nv,$nga,$udi);
+ $NC{unlim_dimId} = $udi;
+
+ for (my($d)=0; $d<$nd; $d++) { # dimensions
+ my($dnm,$ln);
+ NetCDF::diminq($NC{id},$d,$dnm,$ln);
+ $NC{dimName}[$d] = $dnm;
+ $NC{dimId}{$dnm} = $d;
+ $NC{dimLen}{$dnm} = $ln;
+ }
+
+ for (my($v)=0; $v<$nv; $v++) { # vars & var-attribs
+ my($vnm,$vtp,$nvd,$nva);
+ my(@dids) = ();
+ NetCDF::varinq($NC{id},$v,$vnm,$vtp,$nvd,\@dids,$nva);
+ $NC{varName}[$v] = $vnm;
+ $NC{varId}{$vnm} = $v;
+ $NC{varType}{$vnm} = $vtp;
+ @{$NC{varDimIds}{$vnm}} = @dids[0..$nvd-1];
+
+ for (my($a)=0; $a<$nva; $a++) { # var-attribs
+ my($anm,$atp,$aln);
+ NetCDF::attname($NC{id},$v,$a,$anm);
+ $NC{varAttrName}{$vnm}[$a] = $anm;
+ NetCDF::attinq($NC{id},$v,$anm,$atp,$aln);
+ $NC{varAttrType}{$vnm}{$anm} = $atp;
+ $NC{varAttrLen}{$vnm}{$anm} = $aln;
+ if ($atp == NetCDF::BYTE || $atp == NetCDF::CHAR || $aln == 1) {
+ my($val) = "";
+ NetCDF::attget($NC{id},$v,$anm,\$val);
+ $val =~ s{\0+$}{} if ($atp == NetCDF::CHAR); # trailing \0
+ $NC{varAttr}{$vnm}{$anm} = $val;
+ }
+ }
+ }
+
+ for (my($a)=0; $a<$nga; $a++) { # global attribs
+ my($anm,$atp,$aln);
+ NetCDF::attname($NC{id},NetCDF::GLOBAL,$a,$anm);
+ $NC{attrName}[$a] = $anm;
+ NetCDF::attinq($NC{id},NetCDF::GLOBAL,$anm,$atp,$aln);
+ $NC{attrType}{$anm} = $atp;
+ $NC{attrLen}{$anm} = $aln;
+ if ($atp == NetCDF::BYTE || $atp == NetCDF::CHAR || $aln == 1) {
+ my($val) = "";
+ NetCDF::attget($NC{id},NetCDF::GLOBAL,$anm,\$val);
+ $val =~ s{\0+$}{} if ($atp == NetCDF::CHAR);
+ $NC{attr}{$anm} = $val;
+ }
+ }
+
+ return %NC;
+}
+
+#----------------------------------------------------------------------
+# create new nc file and write metadata
+#
+# INPUT:
+# <filename>
+# <abscissa> name of unlimited dimension
+# <suppress-params> if true, don't write %PARAMs
+#
+# OUTPUT:
+# <netcdf id>
+#
+# NOTES:
+# - netcdf types can be set with %<var>:NC_type to
+# byte, long, short, double
+# - string types are as in old PASCAL convention (e.g. string80)
+# - default type is NetCDF::DOUBLE
+# - %<var>:NC_type are not added to ATTRIBs
+#----------------------------------------------------------------------
+
+sub NC_writeMData($$$)
+{
+ my($fn,$abscissa,$suppress_params) = @_;
+ my(%attrDone,@slDim,@NCtype);
+
+ my($ncId) = NetCDF::create($fn,NetCDF::CLOBBER);
+ NetCDF::setfill($ncId,NetCDF::NOFILL); # NetCDF library bug
+
+ # DIMENSIONS
+ my($aid) = NetCDF::dimdef($ncId,$abscissa,NetCDF::UNLIMITED);
+
+ for (my($f)=0; $f<=$#antsLayout; $f++) { # types
+ my($tpa) = $antsLayout[$f] . ':NC_type';
+ my($sl) = ($P{$tpa} =~ m{^string(\d+)$});
+ if ($sl > 0) { # string
+ $slDim[$f] = NetCDF::dimdef($ncId,"$antsLayout[$f]:strlen",$sl);
+ $NCtype[$f] = NetCDF::CHAR;
+ } elsif (defined($P{$tpa})) { # custom
+ $NCtype[$f] = NC_type($P{$tpa});
+ } else { # default
+ $NCtype[$f] = NetCDF::DOUBLE;
+ }
+# printf(STDERR "type %s set to %s\n",$antsLayout[$f],NC_typeName($NCtype[$f]));
+ undef($P{$tpa}); # do not add to ATTRIBs
+ }
+
+ for (my($f)=0; $f<=$#antsLayout; $f++) { # VARIABLES
+ my($vid);
+ if (defined($slDim[$f])) {
+ $vid = NetCDF::vardef($ncId,$antsLayout[$f],$NCtype[$f],[$aid,$slDim[$f]]);
+ } else {
+ $vid = NetCDF::vardef($ncId,$antsLayout[$f],$NCtype[$f],[$aid]);
+ }
+ croak("$0: varid != fnr (implementation restriction)")
+ unless ($vid == $f);
+ foreach my $anm (keys(%P)) { # variable attributes
+ next unless defined($P{$anm});
+ my($var,$attr) = ($anm =~ m{([^:]+):(.*)});
+ next unless ($var eq $antsLayout[$f]);
+ $attrDone{$anm} = 1; # mark
+ if (numberp($P{$anm}) || lc($P{$anm}) eq nan) {
+ NetCDF::attput($ncId,$f,$attr,NetCDF::DOUBLE,$P{$anm});
+ } else {
+ NetCDF::attput($ncId,$f,$attr,NetCDF::CHAR,$P{$anm});
+ }
+ }
+ }
+
+ unless ($suppress_params) {
+ foreach my $anm (keys(%P)) { # GLOBAL ATTRIBUTES
+ next unless defined($P{$anm});
+ next if ($anm eq 'FILENAME' || $anm eq 'DIRNAME' || # skip pseudo
+ $anm eq 'BASENAME' || $anm eq 'EXTN' ||
+ $anm eq 'PATHNAME' ||
+ $anm eq 'RECNO' || $anm eq 'LINENO');
+ next if $attrDone{$anm};
+ if (numberp($P{$anm}) || lc($P{$anm}) eq nan) {
+ NetCDF::attput($ncId,NetCDF::GLOBAL,$anm,NetCDF::DOUBLE,$P{$anm});
+ } else {
+ NetCDF::attput($ncId,NetCDF::GLOBAL,$anm,NetCDF::CHAR,$P{$anm});
+ }
+ }
+ }
+
+ NetCDF::endef($ncId);
+
+ return $ncId;
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/antsusage.pl
@@ -0,0 +1,628 @@
+#/usr/bin/perl
+#======================================================================
+# A N T S U S A G E . P L
+# doc: Fri Jun 19 13:43:05 1998
+# dlm: Mon Feb 13 19:57:03 2012
+# (c) 1998 A.M. Thurnherr
+# uE-Info: 441 0 NIL 0 0 70 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Dec 30, 1998: - removed directory from $0
+# - added global -P option (pass comments)
+# Jan 02, 1999: - changed -P to -T and added -P)refix for [./fnr]
+# Feb 08, 1999: - added &antsUsageError()
+# Feb 17, 1999: - added -N
+# Feb 28, 1999: - forced string interpretation for -O, -R, -I
+# Mar 08, 1999: - added -L, $antsLibs
+# Mar 20, 1999: - added exit(1) for unknown options
+# - added optional argument to &antsUsageError()
+# May 28, 1999: - library loading generated headers even on -Q
+# Jun 31, 1999: - added &antsDescription()
+# Jul 31, 1999: - added parameter typechecking (field, float, card, int, file)
+# Aug 02, 1999: - changed &antsDescription() to be option-dependent
+# Sep 18, 1999: - added option delimiter --
+# - treat cardinals & integers differently
+# - added option typechecking funs, e.g. &antsIntOpt()
+# - auto set -Q if stdout is tty
+# Sep 19, 1999: - changed &getopts() from Perl4 to Perl5
+# Sep 21, 1999: - load local libraries first
+# Mar 06, 2000: - added for-M)at
+# Mar 07, 2000: - worked on -M
+# Aug 24, 2000: - removed setting -Q on tty (bad for [yoyo] and [Split])
+# Aug 28, 2000: - added -Z
+# - changed -P to -A
+# - added new -P
+# Sep 19, 2000: - set opt_M (dodgily) if not specifically set (only affects
+# [count] so far)
+# Sep 20, 2000: - added []-syntax to -P
+# - added workaround for -M %0xd bug
+# Sep 25, 2000: - changed order of -P and -L processing
+# Sep 26, 2000: - cosmetics
+# Nov 13, 2000: - BUG: -- had left a single empty argument
+# Nov 15, 2000: - added &antsParamParam()
+# - added &antsFileOpt()
+# Nov 17, 2000: - made -P override any header PARAMs
+# Jan 4, 2001: - moved -L processing before -P
+# Feb 8, 2001: - added -G)range option
+# Mar 17, 2001: - param->arg
+# - added @file:field argument syntax
+# - added #num-num[:step] syntax
+# Mar 23, 2001: - added prefix{#-#}suff syntax
+# Mar 31, 2001: - changed -G)range to #[..#]{,#[..#}
+# - added -F)ields f{,f}
+# Apr 3, 2001: - added +f syntax to -F)ields
+# Apr 5, 2001: - added f+ syntax to -F)ields
+# Apr 24, 2001: - removed err msg in case of -G f:* (select numbers)
+# Apr 30, 2001: - shortened date, added pwd
+# Jun 23, 2001: - removed default setting of $opt_M
+# Jul 6, 2001: - added degree notation to &antsFloatArg() via str2num()
+# Jul 10, 2001: - added select field names (for V.3)
+# Jul 13, 2001: - store ONLY field names (replaced on 1st use)
+# - added quotes to usage history
+# Jul 15, 2001: - added &antsNewFieldOpt()
+# Jul 16, 2001: - made it work with Description again
+# Jul 24, 2001: - removed fnr lookup on -G
+# Jul 30, 2001: - BUG: made parseHeader conditional on $antsFixedFormat
+# Aug 9, 2001: - chgd pref{#-#}suff syntax to expand only to exist files
+# Oct 28, 2001: - BUG: added -K handling before parseHeader
+# Nov 22, 2001: - moved logic into &antsParseHeader()
+# Nov 28, 2001: - cosmetics
+# Jan 18, 2002: - old -N => -X; new -N
+# Mar 24, 2002: - BUG: &antsFieldArg('file') did not handle %PARAMs correctly
+# Jul 26, 2002: - removed common usage from antsUsageError unless -U is set
+# Jan 6, 2003: - added regexp option to -G
+# Feb 9, 2003: - BUG: {103-103}.ens hung
+# Jun 26, 2004: - made sure that near-zero \#args are rounded to zero
+# Jun 27, 2004: - BUG: \#22-14 did not work correctly any more
+# Jul 12, 2004: - removed &antsDescription()
+# May 5, 2005: - added &antsNewField()
+# May 17, 2005: - allowed &antsFieldArg() to check [Layout]
+# Nov 1, 2005: - disallowed numeric options by adding -- if first argument
+# begins with -[0-9]
+# Nov 8, 2005: - removed -P, -T => -P, -Z => -T, added -Z
+# Nov 17, 2005: - removed $antsLibs
+# - removed remainder of -D
+# - added $antsARGV0 for [yoyo]
+# - added !<arg> quoting (for filenames)
+# Nov 18, 2005: - finally allowed %PARAMs in -G
+# Nov 21, 2005: - BUG: had not been allowed in -G fieldname
+# Dec 7, 2005: - antsFName -> antsLayout (not tested)
+# Dec 9, 2005: - Version 3.2 (see [HISTORY])
+# Dec 11, 2005: - error on 0 args & tty stdin
+# Dec 20, 2005: - created &antsFieldInFileArg() & added flag to &antsFieldArg
+# - simplified opt_M, because it now works w/o $#
+# Dec 22, 2005: - added $antsInteractive for [abc]
+# Dec 23, 2005: - replaced defined(@array) (c.f. perlfunc(1))
+# Dec 31, 2005: - BUG: @-notation was broken (used antique [fields]!!!)
+# Jan 3, 2006: - added support for -S)elect
+# Jan 9, 2006: - removed old line-masking code
+# Jan 12, 2006: - removed -A support
+# - removed support for $ENV{ANTS}
+# - changed from old -H)eader <skip> to -H)ead <n lines>
+# Jan 13, 2006: - moved -G handling to -S
+# - BUG: -G regexpr did not allow :
+# - renamed -T)rim to -C)anonical
+# - removed warnings on -M/-C
+# - removed weird -Z)ap
+# Jan 14, 2006: - removed -G (now handled by -S)
+# - changed semantics of pref{#-#}suff special arg to
+# expand non-existing file names
+# Jul 28, 2006: - made special arg #-#:# numerically more robust
+# Aug 18, 2006: - improved special arg to pref{#,#-#,...} and allow / instead of ,
+# Dec 14, 2006: - exported handling of -X to [antsio.pl]
+# - disallow -P & -Q
+# May 31, 2007: - added -G
+# Nov 28, 2007: - replaced / by + to separate ranges in {} arguments
+# Mar 4, 2008: - disallow partial fname matches in antsNewField*()
+# Mar 24, 2008: - new usage formatting (glorious!)
+# Mar 25, 2008: - added $antsSummary
+# Mar 26, 2008: - extended -F syntax
+# Mar 27, 2008: - modified &antsUsage() to allow disabling common options
+# Apr 24, 2008: - added &antsFieldListOpt()
+# May 7, 2008: - disabled -N/-S for utilities without header parsing
+# May 13, 2008: - moved -U to standard usage message
+# Aug 5, 2008: - suppress empty usage lines
+# Nov 12, 2008: - added opt_T
+# Aug 24, 2009: - added V4 dependency on @file:field special args, file args & opts
+# Oct 3, 2009: - BUG: sometime recently I had changed the pref{}suff semantics to be
+# much more permissive; this led to problems as args like {print $0}
+# were erroneously expanded; changed => pref{}suff is only expanded
+# if first expanded element is existing file
+# - special args expanding to zilch are not expanded any more
+# Aug 16, 2010: - added -A)ctivate output (F/S Poseidon, P403, Lucky Strike)
+# Aug 28, 2010: - added suppress -D)ependency check option
+# - improve common-options usage help
+# Oct 15, 2010: - removed diagnostic output about loading libs
+# Oct 29, 2010: - replaced list by Cat in expansion of @-special args
+# Dec 21, 2010: - made $@ at end of -F list optional (i.e. -F can end with ,)
+# Jul 21, 2011: - modified -D usage info
+# Sep 19, 2011: - SEMANTICS: pref{#-#}suff does now produce warning on missing files
+# Oct 3, 2011: - BUG: pref{}suff special args were (again) too permissive and matched
+# output formats; this time, I solved problem by making regexp
+# more restrictive; if this does not work, I can go back to
+# earlier solution (see BUG Oct 3 2009)
+# Oct 16, 2011: - added support for \, escape in -F to protect commas used, e.g. in
+# function calls, from splitting the opt_F argument string
+# Nov 11, 2011: - BUG: antsNewField did not work for external layouts
+# Dec 29, 2011: - BUG: antsNewField did not work Cat -f c=1,1,10 without input
+# - BUG: antsNewField did still not work for external layouts (the bug
+# resulted in always extending the layout, even when the field already
+# existed)
+# Feb 13, 2012: - antsNewFieldOpt simplified by using 2nd arg to fnrNoErr
+
+# NOTES:
+# - ksh expands {}-arguments with commas in them!!! Use + instead
+
+use Getopt::Std;
+
+sub antsUsageError() { # die with Usage error
+ if (defined($antsSummary)) {
+ print(STDERR "\n$0 -- $antsSummary\n\n")
+ } else {
+ print(STDERR "\n$0\n\n")
+ }
+ if ($opt_U) {
+ print(STDERR "Options & Arguments: $antsCurUsage$_[0]\n\nCommon options:\n" .
+ "\t[-F)ields {%P|f|[\$@]|[f]=expr}[,...]]\n" .
+ "\t[num for-M)at] [-C)anonical numbers] [-G)eographic lat/lon]\n" .
+ "\t[-A)ctivate output] [LaTeX -T)able output]\n" .
+ "\t[-S)elect <addr-expr>] [-N)ums f[,...]] [-H)ead <n lines>]\n" .
+ "\t[-P)ass comments] [-Q)uiet (no headers)] [-X (no new header)]\n" .
+ "\t[suppress -D)ependency checks & addition of new dependencies]\n" .
+ "\t[-L)oad <lib,...>]\n" .
+ "\t[-I)n field-sep] [-O)ut field-sep] [-R)ecord sep]\n");
+ } else {
+ print(STDERR "Options & Arguments: $antsCurUsage$_[0]\n");
+ }
+ croak("\n");
+}
+
+# NB: "-" as first char in opts string disables common-option processing
+
+sub antsUsage($$@) { # handle options
+ my($opts,$min,@usage) = @_;
+ my($cOpts) = 'ADM:QN:XCGPH:UI:O:R:L:F:S:T';
+ my($d,$p);
+ $antsCurUsage .= "\n\t[print full -U)sage]";
+ foreach my $uln (@usage) {
+ $antsCurUsage .= "\n\t$uln" # suppress emtpy, e.g.
+ unless ($uln eq ''); # for interp. model usage
+ }
+
+ &antsUsageError() # no args && tty stdin
+ if (!$antsInteractive && $min == 0 && @ARGV == 0 && -t 0);
+
+ unshift(@ARGV,'--') if ($ARGV[0] =~ /^-\d/); # -ve number heuristics
+
+ chomp($0 = `basename $0`); # set scriptname
+ chop($d = `date +%D`); # build header line
+ chop($p = `pwd`);
+ $p = "..." . substr($p,-17) if (length($p) > 20);
+ $antsCurHeader = "#ANTS# [$d $p] $0";
+ my($i,$eoo);
+ for ($i=0; $i<=$#ARGV; $i++) {
+ $antsCurHeader .= " '$ARGV[$i]'";
+ $eoo = 1 if ($ARGV[$i] eq '--'); # -- handling
+ $ARGV[$i] = "!$ARGV[$i+1]" if ($eoo); # make -ve non-options
+ }
+ $antsCurHeader .= "\n";
+ pop(@ARGV) if ($eoo); # remove last ARG
+
+ if ($opts =~ m{^-}) { # no common options processing
+ $opts = $';
+ undef($cOpts);
+ }
+ &antsUsageError(), exit(1) # parse options
+ unless (&getopts($cOpts . $opts));
+
+ unless ($antsParseHeader) {
+ croak("$0: -S not supported (implementation restriction)\n")
+ if defined($opt_S);
+ croak("$0: -N not supported (implementation restriction)\n")
+ if defined($opt_N);
+ }
+
+
+ if ($eoo) { # reset args
+ for ($i=0; $i<=$#ARGV; $i++) {
+ $ARGV[$i] = substr($ARGV[$i],1);
+ }
+ }
+
+ if (defined($cOpts)) { # process common options
+
+ croak("$0: illegal option combination (-P & -Q)\n")
+ if ($opt_P && $opt_Q);
+
+ &antsActivateOut() if ($opt_A); # activate output
+
+ if ($opt_T) { # LaTeX table output
+ croak("$0: illegal option combination (-T & -G)\n")
+ if ($opt_G);
+ croak("$0: illegal option combination (-T & -O)\n")
+ if defined($opt_O);
+ $opt_O = ' & ';
+ croak("$0: illegal option combination (-T & -R)\n")
+ if defined($opt_R);
+ $opt_R = ' \\\\\\\\\n';
+ }
+
+ if (defined($opt_I)) { # defaults
+ eval('$opt_I = "' . $opt_I .'";'); # interpret strings
+ } else { # ... as perl strings
+ $opt_I = '\s+';
+ }
+ if (defined($opt_O)) {
+ eval('$opt_O = "' . $opt_O .'";');
+ } else {
+ $opt_O = "\t";
+ }
+ if (defined($opt_R)) {
+ eval('$opt_R = "' . $opt_R .'";');
+ } else {
+ $opt_R = "\n";
+ }
+
+ if (defined($opt_L)) { # load libraries
+ foreach $lib (split(',',$opt_L)) {
+ if (-r "lib$lib.pl") {
+# &antsInfo("loading ./lib$lib.pl");
+ require "lib$lib.pl";
+ } else {
+# &antsInfo("loading $ANTS/lib$lib.pl"),
+ require "$ANTS/lib$lib.pl";
+ }
+ }
+ }
+
+ if (defined($opt_N)) { # parse -N)ums
+ @antsNFNames = split(',',$opt_N);
+ }
+
+ if (defined($opt_F)) { # parse -F)ields
+ $opt_F =~ s/\\,/aNtScOmMa/g;
+ @antsOutExprs = split(',',$opt_F);
+ push(@antsOutExprs,'$@') if ($opt_F =~ /,$/);
+ foreach my $e (@antsOutExprs) {
+ $e =~ s/aNtScOmMa/,/;
+ }
+ }
+ }
+
+ my($ai);
+ for ($ai=0; $ai<=$#ARGV; $ai++) { # parse special args
+ my(@exp);
+ if ($ARGV[$ai] =~ /^@([^:]+):(.+)/) { # @file:field
+ &antsAddDeps($1);
+ @exp = `Cat -QF$2 $1`;
+ croak("(...while expanding $ARGV[$ai])\n") if ($?);
+ } elsif ($ARGV[$ai] =~ /^#(-?[\d\.]+)-(-?[\d\.]+):?(-?[\d\.]+)?/) {
+ my($step) = 1; # #num-num:step
+ if (defined($3)) {
+ $step = $3;
+ } elsif ($2 < $1) {
+ $step = -1;
+ }
+ if ($step > 0) {
+ for (my($c)=0,my($i)=$1; $i<=$2+$step/1e6; $c++,$i=$1+$c*$step) {
+ $i = 0 if (abs($i) < abs($step) / 1e6);
+ push(@exp,$i);
+ }
+ } else {
+ for (my($c)=0,my($i)=$1; $i>=$2+$step/1e6; $c++,$i=$1+$c*$step) {
+ $i = 0 if (abs($i) < abs($step) / 1e6);
+ push(@exp,$i);
+ }
+ }
+# } elsif ($ARGV[$ai] =~ m{\{([^\}]+)\}}) { # pref{list of ranges}suff
+ } elsif ($ARGV[$ai] =~ m{\{([-\+,\d]+)\}}) { # pref{list of ranges}suff
+ my($pref) = $`; my($suff) = $';
+ foreach my $range (split('[,\+]',$1)) {
+ if ($range =~ /^(\d+)-(\d+)$/) {
+ my($fmt) = length($1)==length($2) ?
+ sprintf("$pref%%0%dd$suff",length($1)) : "$pref%d$suff";
+ if ($2 > $1) {
+ for (my($i)=$1; $i<=$2; $i++) {
+ my($f) = sprintf($fmt,$i);
+ if (-f $f) { push(@exp,$f); }
+ else { &antsInfo("$ARGV[$ai]: no file <$f>"); }
+ }
+ } else {
+ for (my($i)=$1; $i>=$2; $i--) {
+ my($f) = sprintf($fmt,$i);
+ if (-f $f) { push(@exp,$f); }
+ else { &antsInfo("$ARGV[$ai]: no file <$f>"); }
+ }
+ }
+ } else {
+ my($f) = "$pref$range$suff";
+ if (-f $f) { push(@exp,$f); }
+ else { &antsInfo("$ARGV[$ai]: no file <$f>"); }
+ }
+ @exp = ($ARGV[$ai]) # make sure it *was* special arg
+ unless (@exp);
+ }
+ } else { # regular argument
+ next;
+ }
+ &antsInfo("WARNING: special arg $ARGV[$ai] expands to nothing"),
+ push(@exp,$ARGV[$ai])
+ unless ($#exp >= 0);
+ splice(@ARGV,$ai,1,@exp);
+ }
+
+ my($nargs) = $#ARGV + 1; # check arg count
+ &antsUsageError() if ($opt_U || ($min > 0) && ($nargs < $min));
+
+ $antsARGV0 = $ARGV[0]; # save 1st filename
+ &antsParseHeader(); # get fields & params
+
+ for (my($i)=0; $i<=$#ARGV; $i++) { # remove leading ! from args
+ $ARGV[$i] =~ s/^!//;
+ }
+
+ return $nargs;
+}
+
+#======================================================================
+# argument typechecking
+#======================================================================
+
+sub antsFieldInFileArg($)
+{
+ my($fn) = @_;
+ my($fnr);
+
+ &antsUsageError() unless defined($ARGV[0]);
+ open(F,$fn) || croak("$fn: $!\n");
+ if ($ARGV[0] =~ /^%/) {
+ croak("$0: no PARAM $ARGV[0] in $fn\n")
+ unless (defined(&antsFileScanParam(F,$')));
+ $fnr = $ARGV[0];
+ } else {
+ $fnr = &antsFileScanFnr(F,$ARGV[0]);
+ unless (defined($fnr)) {
+ print(STDERR "$0: WARNING: no field $ARGV[0] in $fn\n");
+ $fnr = &fnr($ARGV[0]);
+ }
+ }
+ close(F);
+
+ shift(@ARGV);
+ return $fnr;
+}
+
+sub antsFieldArg($)
+{
+ &antsUsageError() unless defined($ARGV[0]);
+ my($paramsAllowed) = @_;
+ my($fnr) = &fnr($ARGV[0]);
+ croak("$0: $ARGV[0] is not a field\n")
+ unless (numberp($fnr) || $paramsAllowed);
+ shift(@ARGV);
+ return $fnr;
+}
+
+sub antsFieldOpt(@)
+{
+ my($opt,$default) = @_;
+ if (ref($opt)) { # reference => set
+ if (defined(${$opt})) { # defined => check,set
+ ${$opt} = &fnr(${$opt});
+ } elsif (defined($default)) { # not defined => default
+ ${$opt} = &fnr($default);
+ }
+ return ${$opt};
+ } else { # not ref => do not set
+ return defined($opt) ? &fnr($opt) :
+ defined($default) ? &fnr($default) : $opt;
+ }
+}
+
+sub antsFieldListOpt($)
+{
+ my($opt) = @_;
+ my(@fn) = split(',',$opt);
+ my(@fi);
+
+ for (my($i)=0; $i<@fn; $i++) {
+ $fi[$i] = &fnr($fn[$i]);
+ }
+ return @fi;
+}
+
+sub antsNewField($) # allocate if needed
+{
+ my($fname) = @_;
+ my($fnr);
+
+ $fnr = &fnrNoErr($fname,1); # exact match
+ unless (defined($fnr)) {
+ return $antsBufNFields++ # external layout
+ unless ($antsBufNFields==0 || @antsLayout);
+ @antsNewLayout = @antsLayout
+ unless (@antsNewLayout);
+ push(@antsNewLayout,$fname);
+ $fnr = $#antsNewLayout;
+ }
+ $antsBufNFields = $fnr+1 if ($fnr >= $antsBufNFields);
+ return $fnr;
+}
+
+sub antsNewFieldOpt(@) # allocate if does not exist
+{
+ my($opt,$default) = @_;
+ my($fname,$fnr);
+
+ if (ref($opt)) { # reference => set
+ if (defined(${$opt})) { # defined => check,set
+ $fname = ${$opt};
+ } elsif (defined($default)) { # not defined => default
+ $fname = $default;
+ }
+ if (defined($fname)) {
+ $fnr = &antsNewField($fname);
+ ${$opt} = $fnr;
+ return $fnr;
+ } else { return undef; }
+ } else { # not ref => do not set
+ if (defined($opt)) {
+ $fname = $opt;
+ } elsif (defined($default)) {
+ $fname = $default;
+ }
+ return defined($fname) ? &antsNewField($fname) : undef;
+ }
+}
+
+sub antsNoFileErr($$)
+{
+ croak("$0: $_[0] $_[1] is not a valid file\n")
+ unless (-r $_[1]);
+ &antsAddDeps($_[1]);
+}
+
+sub antsFileArg() # arg 1 => do not shift
+{
+ &antsUsageError() unless defined($ARGV[0]);
+ &antsNoFileErr("Argument",$ARGV[0]);
+ my($res) = $ARGV[0];
+ shift(@ARGV) unless ($_[0]);
+ return $res;
+}
+
+sub antsFileOpt($)
+{
+ my($opt) = @_;
+ &antsNoFileErr("Option Argument",$opt)
+ if (defined($opt));
+}
+
+sub antsParamArg()
+{
+ &antsUsageError() unless defined($ARGV[0]);
+ croak("$0: Argument $ARGV[0] is not a valid PARAM\n")
+ unless ($ARGV[0] =~ /^%/);
+ shift(@ARGV);
+ return $';
+}
+
+sub antsNoCardErr($$)
+{
+ croak("$0: $_[0] $_[1] is not a cardinal number\n")
+ unless (cardinalp($_[1]));
+}
+
+sub antsCardArg()
+{
+ &antsUsageError() unless defined($ARGV[0]);
+ $ARGV[0] = &{&antsCompileConstExpr($')}
+ if ($ARGV[0] =~ m{^=});
+ &antsNoCardErr("Argument",$ARGV[0]);
+ my($res) = 1.0*$ARGV[0];
+ shift(@ARGV);
+ return $res;
+}
+
+sub antsCardOpt(@)
+{
+ my($opt,$default) = @_;
+ if (ref($opt)) { # reference => set
+ if (defined(${$opt})) { # defined => check
+ $$opt = &{&antsCompileConstExpr($')} if ($$opt =~ m{^=});
+ &antsNoCardErr("Option Argument",${$opt});
+ } else { # not defined => default
+ ${$opt} = $default;
+ }
+ return ${$opt};
+ } else { # not ref => do not set
+ if (defined($opt)) {
+ $opt = &{&antsCompileConstExpr($')} if ($opt =~ m{^=});
+ &antsNoCardErr("Option Argument",$opt);
+ return $opt;
+ } else {
+ return $default;
+ }
+ }
+}
+
+sub antsNoIntErr($$)
+{
+ croak("$0: $_[0] $_[1] is not an integer\n")
+ unless (integerp($_[1]));
+}
+
+sub antsIntArg()
+{
+ &antsUsageError() unless defined($ARGV[0]);
+ $ARGV[0] = &{&antsCompileConstExpr($')}
+ if ($ARGV[0] =~ m{^=});
+ &antsNoIntErr("Argument",$ARGV[0]);
+ my($res) = 1.0*$ARGV[0];
+ shift(@ARGV);
+ return $res;
+}
+
+sub antsIntOpt(@)
+{
+ my($opt,$default) = @_;
+ if (ref($opt)) { # reference => set
+ if (defined(${$opt})) { # defined => check
+ $$opt = &{&antsCompileConstExpr($')} if ($$opt =~ m{^=});
+ &antsNoIntErr("Option Argument",${$opt});
+ } else { # not defined => default
+ ${$opt} = $default;
+ }
+ return ${$opt};
+ } else { # not ref => do not set
+ if (defined($opt)) {
+ $opt = &{&antsCompileConstExpr($')} if ($opt =~ m{^=});
+ &antsNoIntErr("Option Argument",$opt);
+ return $opt;
+ } else {
+ return $default;
+ }
+ }
+}
+
+sub antsNoFloatErr($$)
+{
+ croak("$0: $_[0] $_[1] is not a number\n")
+ unless (numberp($_[1]));
+}
+
+sub antsFloatArg()
+{
+ &antsUsageError() unless defined($ARGV[0]);
+ $ARGV[0] = &{&antsCompileConstExpr($')}
+ if ($ARGV[0] =~ m{^=});
+ my($res) = str2num($ARGV[0]);
+ &antsNoFloatErr("Argument",$res);
+ shift(@ARGV);
+ return $res;
+}
+
+sub antsFloatOpt(@)
+{
+ my($opt,$default) = @_;
+ if (ref($opt)) { # reference => set
+ if (defined(${$opt})) { # defined => check
+ $$opt = &{&antsCompileConstExpr($')} if ($$opt =~ m{^=});
+ &antsNoFloatErr("Option Argument",${$opt});
+ } else { # not defined => default
+ ${$opt} = $default;
+ }
+ return ${$opt};
+ } else { # not ref => do not set
+ if (defined($opt)) {
+ $opt = &{&antsCompileConstExpr($')} if ($opt =~ m{^=});
+ &antsNoFloatErr("Option Argument",$opt);
+ return $opt;
+ } else {
+ return $default;
+ }
+ }
+}
+
+1; # return true
new file mode 100644
--- /dev/null
+++ b/antsutils.pl
@@ -0,0 +1,566 @@
+#!/usr/bin/perl
+#======================================================================
+# A N T S U T I L S . P L
+# doc: Fri Jun 19 23:25:50 1998
+# dlm: Mon Feb 13 20:13:01 2012
+# (c) 1998 A.M. Thurnherr
+# uE-Info: 94 77 NIL 0 0 70 2 2 4 NIL ofnI
+#======================================================================
+
+# Miscellaneous auxillary functions
+
+# HISTORY:
+# Mar 08, 1999: - added &antsFunUsage()
+# Mar 20, 1999: - added &fnr()
+# - BUG &numberp() returned TRUE on "sigma2"
+# Mar 21, 1999: - added semantics of &antsFunUsage() to specify min
+# args on negative number
+# Mar 22, 1999: - added round(); NB: there's a BUG:
+# int(2.155*10**2+0.5)/100 returns 215!!!
+# Jul 31, 1999: - added &cardinalp() and plugged into &fnr()
+# - change &numberp() to conform with &antsFloatArg()
+# Sep 13, 1999: - added &SQR()
+# - removed "" from valid numbers
+# Sep 18, 1999: - added &integerp()
+# - added typechecking to &antsFunUsage()
+# Sep 20, 1999: - cosmetics
+# Aug 24, 2000: - added #include directive to Description files
+# - added stringlengths to &antsFunUsage()
+# Aug 28, 2000: - added str2num to remove leading 0es & lead/trail spcs
+# - changed opt_P to opt_A
+# Aug 29, 2000: - added &antsRequireParam()
+# Sep 01, 2000: - added prefix as 2nd arg to #include directive
+# - disallow <> in #include directive
+# - debugged &str2num()
+# Sep 03, 2000: - allowed for %param to pass through fnr w/o error check
+# Sep 05, 2000: - str2num always kills leading/trailing spaces
+# Sep 19, 2000: - added interpretation to ./ to #include
+# - inherit prefix for chained inclusion (do not chain, however)
+# Nov 25, 2000: - backslashed leading + in regexp to increase portability
+# May 29, 2001: - adapted &antsNumbers() to handle %PARAMs
+# - added &antsVal()
+# Jul 6, 2001: - added degree notation to str2num()
+# Jul 12, 2001: - made $# notation 1-relative (awk, shell)
+# Jul 15, 2001: - added field name to Description open error
+# Jul 16, 2001: - added &localFnr()
+# Jul 19, 2001: - added &croak()
+# Aug 1, 2001: - BUG: numberp() returned false on "-.360"
+# May 7, 2002: - BUG: numberp() returned true on "."
+# Mar 8, 2003: - changed Description to Layout
+# Dec 7, 2005: - antsFName -> antsLayout (not tested)
+# Dec 8, 2005: - Version 3.2 (see [HISTORY])
+# Dec 12, 2005: - BUG: &outFnr() was broken
+# - BUG: [Layout] overrode local #FIELDS#
+# Dec 23, 2005: - replaced defined(@array) (c.f. perlfunc(1))
+# Jan 2, 2006: - changed numberp to allow for multiple args
+# - changed right back
+# Jan 9, 2006: - BUG: fnrNoErr() had not increased $antsBufNFields on
+# import of an externally defined field
+# Jan 10, 2006: - added &antsLoadModel()
+# Jan 12, 2006: - removed -A support
+# Jan 13: 2006: - BUG: str2num(3.00) did not yield 3
+# Jul 1, 2006: - added isNaN (from perlfunc(1))
+# - changed numberp() according to perldata(1)
+# Jul 24, 2006: - added $PRACTICALLY_ZERO, &equal()
+# Aug 23, 2006: - improved model loading (& added model w. params)
+# Aug 24, 2006: - made 2nd argument of round() optional
+# - added frac()
+# May 11, 2007: - added Floor(), Ceil()
+# Oct 17, 2007: - added default field names (w. caching) to &antsFunUsage()
+# Oct 18, 2007: - added support for optional parameters
+# Oct 19, 2007: - generalized antsFunUsage to allow default %PARAMs
+# - BUG: make sure usage is printed in abc when called with
+# wrong # of args
+# Nov 14, 2007: - made optional arguments to round, Floor, Ceil more intuitive
+# Dec 19, 2007: - added &numbersp()
+# Mar 2, 2008: - adapted fnr to partial matches
+# Mar 4, 2008: - added $antsFnrExactMatch flag
+# - BUG: couldn't select f1 if there is also an f10
+# Mar 26, 2008: - BUG: abbreviated field names were imported from external
+# Layout
+# Mar 27, 2008: - added %pi
+# Mar 28, 2008: - move %pi to [argtest]; when set here filediff -e bombs
+# Apr 15, 2008: - added &log10()
+# Apr 16, 2008: - MAJOR CHANGE: suppress croak() STDOUT error output on -Q
+# Apr 29, 2008: - added &ismember()
+# Jun 11, 2008: - adder perl 5.8.8 bug workaround (0*-0.1 = -0)
+# Nov 12, 2008: - added opt_T
+# Mar 21, 2009: - added debug()
+# Nov 17, 2009: - added listAllRecs flag for list(1)
+# May 12, 2010: - BUG: round() did not work correctly for -ve numbers
+# May 21, 2011: - added support for $antsFnrNegative
+# Nov 11, 2011: - added exact flag to fnrNoErr()
+# Feb 13, 2012: - BUG: failure to specify exact flag resulted in ignoring antsFnrExactMatch
+# - BUG: fnrNoErr disregarded exact flag for external layouts
+
+# fnr notes:
+# - matches field names starting with the string given, i.e. "sig" is
+# really "^sig"
+# - if exact match is desired, a $ can be appended to the field name
+# - following regexp meta chars are auto-quoted: .
+
+#----------------------------------------------------------------------
+# Flags
+#----------------------------------------------------------------------
+
+$antsFnrExactMatch = 0; # set to force exact match, e.g. for antsNewField* [antsutils.pl]
+$antsFnrNegativeOk = 0; # set to allow, e.g., $-1 in [list]
+
+#----------------------------------------------------------------------
+# Error-Exit
+#----------------------------------------------------------------------
+
+sub croak($)
+{
+ print("#ANTS#ERROR# @_[0]") unless (-t 1 || $opt_Q);
+ die(@_[0]);
+}
+
+#----------------------------------------------------------------------
+# Number-related funs
+#----------------------------------------------------------------------
+
+$PRACTICALLY_ZERO = 1e-9;
+$SMALL_AMOUNT = 1e-6;
+
+sub numberp(@)
+{ return $_[0] =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/; }
+
+sub numbersp(@)
+{
+ foreach my $n (@_) {
+ return undef unless numberp($n);
+ }
+ return 1;
+}
+
+sub equal($$)
+{ return (@_ >= 2) && (abs($_[0]-$_[1]) < $PRACTICALLY_ZERO); }
+
+# check whether given val is member of a set
+sub ismember($@)
+{
+ my($val,@set) = @_;
+ for (my($i)=0; $i<@set; $i++) {
+ return 1 if ($val == $set[$i]);
+ }
+ return undef;
+}
+
+sub isnan($) # perlfunc(1)
+{ return $_[0] != $_[0]; }
+
+sub cardinalp($)
+{ return $_[0] =~ /^\+?\d+$/; }
+
+sub integerp($)
+{ return $_[0] =~ /^[+-]?\d+$/; }
+
+sub antsNumbers(@)
+{
+ my($n);
+ foreach $n (@_) {
+ return 0 unless (&numberp(&antsVal($n)));
+ }
+ return 1;
+}
+
+sub round(@)
+{
+ my($accuracy) = defined($_[1]) ? $_[1] : 1;
+ return $_[0] >= 0 ? int($_[0] / $accuracy + 0.5) * $accuracy
+ : int($_[0] / $accuracy - 0.5) * $accuracy;
+}
+
+sub Ceil(@)
+{
+ my($accuracy) = defined($_[1]) ? $_[1] : 1;
+ return int($_[0]/$accuracy + 1 - $PRACTICALLY_ZERO) * $accuracy;
+}
+
+sub Floor(@)
+{
+ my($accuracy) = defined($_[1]) ? $_[1] : 1;
+ return int($_[0]/$accuracy) * $accuracy;
+}
+
+sub frac($) { return $_[0] - int($_[0]); }
+
+sub SQR($) { return $_[0] * $_[0]; }
+
+sub str2num($)
+{
+ my($num) = @_;
+ $num =~ s/^\s*//; # kill leading spaces
+ $num =~ s/\s*$//; # kill trailing spaces
+ $num = (substr($1,0,1) eq '-') ? $1-$2/60 : $1+$2/60 # degrees
+ if ($num =~ /^([+-]?\d*):(\d*\.?\d*)$/);
+ return $num unless (numberp($num));
+ $num =~ s/^(-?)0*/\1/; # kill leading 0es
+ $num =~ s/(\.\d*[1-9])0*$/\1/; # kill trailing fractional 0es
+ $num =~ s/^\./0./; # ensure digit before decimal pnt
+ $num =~ s/^-\./-0./; # ditto
+ $num =~ s/\.$/.0/; # ensure digit after decimal pnt
+ $num =~ s/^-0(\.0?)$/0/; # 0 is positive
+ $num =~ s/\.0+$//; # kill trailing fractional 0es
+ return ($num eq "") ? 0 : $num;
+}
+
+sub fmtNum($$) # format number for output
+{
+ my($num,$fname) = @_;
+
+ $num = 0 if ($num eq '-0'); # perl 5.8.8: 0*-0.1 = -0, which is
+ # not handled correctly by all progs
+ $num = str2num($num) if ($opt_C);
+ if ($opt_G && numberp($num)) {
+ $num = sprintf("%d:%04.1f%s",
+ abs(int($num)),
+ (abs($num)-abs(int($num)))*60,
+ $num>=0 ? "N" : "S")
+ if (lc($fname) =~ /lat/);
+ $num = sprintf("%d:%04.1f%s",
+ abs(int($num)),
+ (abs($num)-abs(int($num)))*60,
+ $num>=0 ? "E" : "W")
+ if (lc($fname) =~ /lon/);
+ }
+ if ($opt_T && numberp($num)) {
+ $num = sprintf("\\lat%s{%d}{%04.1f}",
+ $num>=0 ? "N" : "S",
+ abs(int($num)),
+ (abs($num)-abs(int($num)))*60)
+ if (lc($fname) =~ /lat/);
+ $num = sprintf("\\lon%s{%d}{%04.1f}",
+ $num>=0 ? "E" : "W",
+ abs(int($num)),
+ (abs($num)-abs(int($num)))*60)
+ if (lc($fname) =~ /lon/);
+ }
+ $num = sprintf($opt_M,$num)
+ if defined($opt_M) && numberp($num);
+
+ return $num;
+}
+
+sub log10 { my $n = shift; return log($n)/log(10); } # c.v. perlfunc(1)
+
+
+#----------------------------------------------------------------------
+# Layout-related funs
+#----------------------------------------------------------------------
+
+sub fname_match($$) # modified regexp match
+{
+ my($pat,$trg) = @_;
+ return ($pat eq $trg) if ($antsFnrExactMatch); # exact match (pre 3.4 behavior)
+# print(STDERR "pattern: $pat -> ");
+ $pat =~ s/\./\\\./g; # may want more of these
+ $pat =~ s/^/\^/;
+# print(STDERR "$pat\n");
+ return $trg =~ /$pat/;
+}
+
+sub fnrInFile(...)
+{
+ my($fname,$file,$pref,$found) = @_;
+ my($fullName);
+ local(*D);
+ open(D,$file) || return (undef,$fname);
+ while (<D>) {
+ s/\s\b/ $pref/g if m/^#\d+/;
+ my(@fn) = split;
+ if (/^#\s*include\s*([^\s]+)\s*([^\s]+)?/) {
+ my($npref) = ($2 eq "") ? $pref : $2;
+ if (substr($1,0,2) eq "./") {
+ my($dirname) = $file;
+ $file = $1;
+ $dirname =~ s@[^/]+$@@;
+ $file = $dirname . $file;
+ } else {
+ $file = $1;
+ }
+ ($found,$fullName) = &fnrInFile($fname,$file,$npref,$found);
+ }
+ next unless ($fn[0] =~ /^#\d+$/);
+ for (my($i)=1; $i<=$#fn; $i++) {
+ close(D),return ($1,$fname)
+ if (/^#(\d+)\b.*\b$fname\b/);
+ }
+ for (my($i)=1; $i<=$#fn; $i++) {
+ next unless fname_match($fname,$fn[$i]);
+ croak("$0: $fname matches multiple fields in Layout files\n")
+ if defined($found);
+ $fullName = $fn[$i];
+ ($found) = ($fn[0] =~ /^#(\d+)/);
+ }
+ }
+ close(D);
+ return ($found,$fullName);
+}
+
+sub localFnr($@)
+{
+ my($fnm,@layout) = @_;
+ my($i,$fnr);
+
+# print(STDERR "finding $fnm...\n");
+ croak("$0: illegal 0-length field name\n")
+ if ($fnm eq "");
+ return $fnm if ($fnm =~ /^%/);
+ if ($fnm =~ /^\$/) {
+ croak("$0: invalid field identifier \$$'\n")
+ unless (cardinalp($'));
+ return $' - 1;
+ }
+ my($i,$found);
+ if (@layout) {
+ for ($i=0; $i<=$#layout; $i++) {
+ return $i if ($layout[$i] eq $fnm);
+ }
+ for ($i=0; $i<=$#layout; $i++) {
+ next unless fname_match($fnm,$layout[$i]);
+ croak("$0: $fnm matches multiple fields ($layout[$found],$layout[$i],...)\n")
+ if defined($found);
+ $found = $i;
+ }
+ } else {
+ for ($i=0; $i<=$#antsLayout; $i++) {
+ return $i if ($antsLayout[$i] eq $fnm);
+ }
+ for ($i=0; $i<=$#antsLayout; $i++) {
+ next unless fname_match($fnm,$antsLayout[$i]);
+ croak("$0: $fnm matches multiple fields ($antsLayout[$found],$antsLayout[$i],...)\n")
+ if defined($found);
+ $found = $i;
+ }
+ }
+ return $found;
+}
+
+sub fnrNoErr($)
+{
+ my($fnm,$exact) = @_;
+
+ my($tmp) = $antsFnrExactMatch;
+ $antsFnrExactMatch = $exact if defined($exact);
+ my($fnr) = &localFnr($fnm);
+ $antsFnrExactMatch = $tmp;
+
+ my($fullName);
+
+ return $fnr if defined($fnr); # internal layout
+ return $fnm if ($fnm < 0 && $antsFnrNegativeOk); # e.g. for $-1 in [list]
+
+ my($tmp) = $antsFnrExactMatch;
+ $antsFnrExactMatch = $exact if defined($exact);
+ ($fnr,$fullName) = &fnrInFile($fnm,"Layout",""); # external [Layout]
+ $antsFnrExactMatch = $tmp;
+
+ return undef unless defined($fnr);
+ return undef # [Layout] cannod override
+ if (defined($antsLayout[$fnr]) && # local definition
+ !fname_match($fnm,$antsLayout[$fnr]));
+
+ $antsLayout[$fnr] = $fullName if defined($fullName);# found -> add to local
+ $antsBufNFields = $fnr+1 # can happen on externally
+ if ($antsBufNFields < $fnr+1); # ... defined fields
+ return($fnr);
+}
+
+sub fnr(@)
+{
+ my(@fnm) = @_;
+ my($f,@fnr);
+ for ($f=0; $f<=$#fnm; $f++) {
+ $fnr[$f] = &fnrNoErr($fnm[$f]);
+ next if defined($fnr[$f]); # normal case -> done
+ croak("$0: Unknown field $fnm[$f]\n")
+ unless defined($fnr[$f]);
+ }
+ return(@fnr>1 ? @fnr : $fnr[0]);
+}
+
+# fnr()-equivalent but checks in output format
+# - only used for -F processing => single argument only
+
+sub outFnr($)
+{
+ my($fnm) = @_;
+ my($f,$fnr,$fullName);
+
+ $fnr = &localFnr($fnm,@antsNewLayout);
+ return $fnr if defined($fnr); # normal case -> done
+
+ ($fnr,$fullName) = &fnrInFile($fnm,"Layout",""); # look in [Layout]
+ croak("$0: Unknown field $fnm\n")
+ unless defined($fnr);
+
+ $antsNewLayout[$fnr] = $fullName;
+ return $fnr;
+}
+
+#----------------------------------------------------------------------
+# model-loading funs
+#----------------------------------------------------------------------
+
+sub antsLoadModel($$)
+{
+ my($opt,$pref) = @_;
+ my($name);
+
+ for ($a=0; # find model name
+ $a<=$#ARGV && !($ARGV[$a] =~ m/^-\S*$opt$/);
+ $a++) { }
+ if ($a < $#ARGV) { # found
+ $name = $ARGV[$a+1]; # load it
+ if (-r "$pref.$name") { # local
+ &antsInfo("loading local $pref.$name...");
+ require "$pref.$name";
+ return $name;
+ } else {
+ require "$ANTS/$pref.$name";
+ return $name;
+ }
+ }
+ return undef;
+}
+
+sub antsLoadModelWithArgs($$)
+{
+ my($opt,$pref) = @_;
+
+ for ($a=0; # find model name
+ $a<=$#ARGV && !($ARGV[$a] =~ m/^-\S*$opt$/);
+ $a++) { }
+ if ($a < $#ARGV) { # found
+ my($name,$args) = ($ARGV[$a+1] =~ /([^\(]+)\(([^\)]*)\)$/);
+ $name = $ARGV[$a+1] unless defined($name);
+ if (-r "$pref.$name") { # local
+ &antsInfo("loading local $pref.$name...");
+ require "$pref.$name";
+ return ($name,split(',',$args));
+ } else {
+ require "$ANTS/$pref.$name";
+ return ($name,split(',',$args));
+ }
+ }
+ return undef;
+}
+
+#----------------------------------------------------------------------
+# Misc funs
+#----------------------------------------------------------------------
+
+# return either current field value or PARAM
+sub antsVal($)
+{ return ($_[0] =~ /^%/) ? $P{$'} : $ants_[$ants_][$_[0]]; }
+
+# USAGE:
+# OLD: argc, type-string, errmesg, params to parse
+# NEW: adds between errmesg & params:
+# 1) reference to static array for caching fnrs
+# 2) list (argc elts) of field names
+
+# NOTES:
+# - backward compatible
+# - fnr_caching only works with fixed-argc funs
+# - undef field names denote required arguments that must be
+# supplied by the user, e.g. for dn2date
+
+sub antsFunUsage($$$@)
+{
+ my($argc,$types,$msg,@params) = @_;
+
+ if (ref($params[0]) && @antsLayout>0 && @params<2*$argc+1) { # default params
+ my(@newparams); # 2nd test is for abc
+ my($npi) = $argc+1;
+
+ $listAllRecs = 1; # special flag for list(1)
+
+ if (@{$params[0]} > 0) { # fnrs already in cache
+ for (my($i)=0; $i<@{$params[0]}; $i++) {
+ push(@newparams,defined($params[0]->[$i]) ?
+ &antsVal($params[0]->[$i]) :
+ $params[$npi++]);
+ }
+ return(@newparams);
+ }
+
+ for (my($i)=1; $i<=$argc; $i++) { # fill cache & do tests
+ if (defined($params[$i])) {
+ push(@{$params[0]},&fnr($params[$i]));
+ push(@newparams,&antsVal($params[0]->[$#{$params[0]}]));
+ } else {
+ croak("usage: $msg\n") unless ($npi <= $#params);
+ push(@{$params[0]},undef);
+ push(@newparams,$params[$npi++]);
+ }
+ }
+ croak("usage: $msg\n") unless ($npi > $#params);
+
+ @params = @newparams;
+ } elsif (ref($params[0])) {
+ splice(@params,0,$argc+1);
+ }
+
+ if ($argc >= 0) { # argument count
+ croak("usage: $msg\n") unless (@params == $argc);
+ } else {
+ croak("usage: $msg\n") unless (@params >= -$argc);
+ }
+
+ for (my($i)=0; $i<length($types); $i++) { # type checking
+ $_ = substr($types,$i,1);
+ SWITCH: {
+ last unless defined($params[$i]);
+ &antsNoCardErr("",$params[$i]),last SWITCH if (/c/);
+ &antsNoIntErr("",$params[$i]),last SWITCH if (/i/);
+ &antsNoFloatErr("",$params[$i]),last SWITCH if (/f/);
+ &antsNoFileErr("",$params[$i]),last SWITCH if (/F/);
+ if (/\d/) {
+ croak("$0: $params[$i] is not a string of length $_\n")
+ unless ($_ == length($params[$i]));
+ last SWITCH;
+ }
+ last SWITCH if (/\./);
+ croak("&antsFunUsage: illegal type specifier $_\n");
+ }
+ }
+
+ return @params;
+} # sub antsfunusage()
+
+sub antsRequireParam($)
+{
+ my($pn) = @_;
+ croak("$0: required PARAM $pn not set\n")
+ unless (defined($P{$pn}));
+ return $P{$pn};
+}
+
+
+{ my($term); # STATIC
+
+sub debug($)
+{
+ my($prompt) = @_;
+ unless (defined($term)) { # initialize
+ use Term::ReadLine;
+ $term = new Term::ReadLine $ARGV0;
+ }
+ do {
+ my($expr) = $term->readline("$prompt>");
+ return if ($expr eq 'return');
+ $res = eval($expr);
+ if (defined($res)) { # no error
+ print(STDERR "$res\n");
+ } else { # error
+ print(STDERR "$@");
+ }
+ } while (1);
+}
+
+} # STATIC SCOPE
+
+1;
new file mode 100644
--- /dev/null
+++ b/covsrt.pl
@@ -0,0 +1,46 @@
+#======================================================================
+# C O V S R T . P L
+# doc: Sun Sep 26 18:44:11 1999
+# dlm: Sun Sep 26 18:56:56 1999
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 46 2 NIL 0 0 72 2 2 4 ofnI
+#======================================================================
+
+# 2nd edition covsrt.c adapted to ANTS
+
+# HISTORY:
+# Sep 26, 1999: - created after confusion about old version [covsrt_old.pl]
+
+sub covsrt($$)
+{
+ my($covarR,$iaR) = @_;
+ my($ma) = $#{$covarR};
+ my($mfit) = $#{$iaR};
+ my($i,$j,$k);
+ my($swap);
+
+ for ($i=$mfit+1;$i<=$ma;$i++) {
+ for ($j=1;$j<=$i;$j++) {
+ $covarR->[$i][$j] = 0;
+ $covarR->[$j][$i] = 0;
+ }
+ }
+ $k=$mfit;
+ for ($j=$ma;$j>=1;$j--) {
+ if ($iaR->[$j]) {
+ for ($i=1;$i<=$ma;$i++) {
+ $swap = $covarR->[$i][$k];
+ $covarR->[$i][$k] = $covarR->[$i][$j];
+ $covarR->[$i][$j] = $swap;
+ }
+ for ($i=1;$i<=$ma;$i++) {
+ $swap = $covarR->[$k][$i];
+ $covarR->[$k][$i] = $covarR->[$j][$i];
+ $covarR->[$j][$i] = $swap;
+ }
+ $k--;
+ }
+ }
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/covsrt_old.pl
@@ -0,0 +1,51 @@
+#======================================================================
+# C O V S R T _ O L D . P L
+# doc: Wed Feb 24 17:35:07 1999
+# dlm: Sun Sep 26 18:42:48 1999
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 12 0 NIL 0 0 72 2 2 4 ofnI
+#======================================================================
+
+# COVSRT routine from Numerical Recipes adapted to ANTS
+# NB: this is the 1st edition version using listA!!!!
+
+# Notes:
+# - both @covar and @listA passed by ref
+
+sub covsrt($$)
+{
+ my($covarR,$listAR) = @_;
+ my($ma) = $#{$covarR};
+ my($mfit) = $#{$listAR};
+ my($i,$j);
+ my($swap);
+
+ for ($j=1; $j<$ma; $j++) {
+ for ($i=$j+1; $i<=$ma; $i++) { $covarR->[$i][$j] = 0.0; }
+ }
+ for ($i=1; $i<$mfit; $i++) {
+ for ($j=$i+1; $j<=$mfit; $j++) {
+ if ($listAR->[$j] > $listAR->[$i]) {
+ $covarR->[$listAR->[$j]][$listAR->[$i]] = $covarR->[$i][$j];
+ } else {
+ $covarR->[$listAR->[$i]][$listAR->[$j]] = $covarR->[$i][$j];
+ }
+ }
+ }
+ $swap = $covarR->[1][1];
+ for ($j=1; $j<=$ma; $j++) {
+ $covarR->[1][$j] = $covarR->[$j][$j];
+ $covarR->[$j][$j] = 0.0;
+ }
+ $covarR->[$listAR->[1]][$listAR->[1]] = $swap;
+ for ($j=2; $j<=$mfit; $j++) {
+ $covarR->[$listAR->[$j]][$listAR->[$j]] = $covarR->[1][$j];
+ }
+ for ($j=2; $j<=$ma; $j++) {
+ for ($i=1; $i<=$j-1; $i++) {
+ $covarR->[$i][$j] = $covarR->[$j][$i];
+ }
+ }
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/fft.pl
@@ -0,0 +1,403 @@
+#======================================================================
+# F F T . P L
+# doc: Fri Mar 12 09:20:33 1999
+# dlm: Mon Jul 24 14:58:04 2006
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 241 36 NIL 0 0 72 66 2 4 NIL ofnI
+#======================================================================
+
+# Notes:
+# It was found when rotary-analysing the FLAME current meters that
+# the sign of the frequencies returned was wrong. When investigating
+# the problem it was found that there are two conventions, one called
+# the engineering convention which is followed by Bendat & Piersol
+# [1971], Gonella [1972], and Mooers [1973] but not Numerical Recipes.
+# For real-valued functions it does not matter because the power
+# of the positive and negative frequencies are summed. The engineering
+# convention appears more sensible, however, because it actually leads
+# to the anticlockwise component to be reported as positive frequencies
+# which is consistent with exp(i phi) = cos phi + i sin phi and the
+# usual axes orientations.
+
+# HISTORY:
+# Mar 12, 1999: - adapted from NR
+# Mar 13, 1999: - ``perlified'' (0-relative arrays; return value)
+# Mar 14, 1999: - cosmetic changes
+# Mar 15, 1999: - pad initial/final NaN values with 0es
+# Dec 08, 1999: - adapted for complex FFT
+# Dec 09, 1999: - continued
+# Dec 10, 1999: - BUG: < replaced by <= (no difference)
+# Dec 11, 1999: - investigated wrong frequency sign
+# Dec 14, 1999: - changed one-sided spectra to get half of the f=0 power
+# Mar 04, 2000: - require mean-removal when zero-padding is used
+# - BUG (cosmetic)
+# Mar 05: 2000: - BUG: died even if no padding was done
+# Mar 08, 2000: - removed opt_r hard-coding
+# May 02, 2001: - BUG: RMS was really standard deviation estimator
+# Aug 29, 2003: - BUG: &icFFT did not calc sigma correctly whenever
+# infield == outfield (e.g. [fftfilt] w/o -f)
+# Mar 31, 2004: - added cFFT_bufR()
+# Feb 9, 2005: - added &phase_pos(), &phase_neg()
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+# Jul 24, 2006: - modified to use $PRACTICALLY_ZERO
+
+#----------------------------------------------------------------------
+# FOUR1 routine
+#
+# Notes:
+# - nan will abort FFT!
+# - added power of two assertions
+# - arrays are 0-relative
+# - isig should be set to -1 for FFT and to 1 for reverse FFT (see
+# note above)
+#
+#----------------------------------------------------------------------
+
+sub FOUR1($@) # ($isign, @data) => @fourier coefficients
+{
+ my($isign,@data) = @_;
+ my($n,$mmax,$m,$j,$istep,$i);
+ my($wtemp,$wr,$wpr,$wpi,$wi,$theta);
+ my($tempr,$tempi);
+ my($N) = @data / 2;
+
+ $n = $N << 1; # re-order input
+ $j = 0;
+ for ($i=0; $i<$n-1; $i+=2) {
+ if ($j > $i) {
+ $tempr = $data[$j];
+ $tempi = $data[$j+1];
+ $data[$j] = $data[$i];
+ $data[$j+1] = $data[$i+1];
+ $data[$i] = $tempr;
+ $data[$i+1] = $tempi;
+ }
+ croak("$0 (fft.pl) $N is not a power of two\n")
+ if ($n % 2);
+ $m = $n >> 1;
+ while ($m >= 2 && $j >= $m) {
+ $j -= $m;
+ croak("$0 (fft.pl) $N is not a power of two\n")
+ if ($m % 2);
+ $m >>= 1;
+ }
+ $j += $m;
+ }
+
+# for ($i=0; $i<=$#data; $i+=2) { # dump data
+# print(STDERR "$data[$i]$opt_O$data[$i+1]$opt_R")
+# }
+
+ $mmax = 2; # do FFT
+ while ($n > $mmax) {
+ $istep = $mmax << 1;
+ $theta = $isign*(6.28318530717959/$mmax);
+ $wtemp = sin(0.5*$theta);
+ $wpr = -2.0*$wtemp*$wtemp;
+ $wpi = sin($theta);
+ $wr = 1.0;
+ $wi = 0.0;
+ for ($m=0; $m<$mmax-1; $m+=2) {
+ for ($i=$m; $i<=$n-1; $i+=$istep) {
+ $j = $i + $mmax;
+ $tempr = $wr*$data[$j] - $wi*$data[$j+1];
+ $tempi = $wr*$data[$j+1] + $wi*$data[$j];
+ $data[$j] = $data[$i] - $tempr;
+ $data[$j+1] = $data[$i+1] - $tempi;
+ $data[$i] += $tempr;
+ $data[$i+1] += $tempi;
+ }
+ $wtemp = $wr;
+ $wr = $wr*$wpr - $wi*$wpi + $wr;
+ $wi = $wi*$wpr + $wtemp*$wpi + $wi;
+ }
+ $mmax = $istep;
+ }
+
+ return @data;
+}
+
+#----------------------------------------------------------------------
+# TWOFFT routine
+#
+# Notes:
+# - arrays are 0-relative
+# - array references are used throughout; input arrays are
+# in $ants_[][] style; ouput are simple arrays
+# - isign convention of NR is used here!!!
+#----------------------------------------------------------------------
+
+sub TWOFFT($$$$$$)
+{
+ my($data1R,$fnr1,$data2R,$fnr2,$fft1R,$fft2R) = @_;
+ my($nn3,$nn2,$jj,$j);
+ my($rep,$rem,$aip,$aim);
+ my($n) = scalar(@{$data1R});
+
+ $nn3 = 1 + ($nn2 = 2 + $n + $n);
+ for ($j=1,$jj=2; $j<=$n; $j++,$jj+=2) {
+ $fft1R->[$jj-2] = $data1R->[$j-1][$fnr1];
+ $fft1R->[$jj-1] = $data2R->[$j-1][$fnr2];
+ }
+ @{$fft1R} = FOUR1(1,@{$fft1R});
+ $fft2R->[0] = $fft1R->[1];
+ $fft1R->[1] = $fft2R->[1] = 0;
+ for ($j=3; $j<=$n+1; $j+=2) {
+ $rep = 0.5 * ($fft1R->[$j-1] + $fft1R->[$nn2-$j-1]);
+ $rem = 0.5 * ($fft1R->[$j-1] - $fft1R->[$nn2-$j-1]);
+ $aip = 0.5 * ($fft1R->[$j] + $fft1R->[$nn3-$j-1]);
+ $aim = 0.5 * ($fft1R->[$j] - $fft1R->[$nn3-$j-1]);
+ $fft1R->[$j-1] = $rep;
+ $fft1R->[$j] = $aim;
+ $fft1R->[$nn2-$j-1] = $rep;
+ $fft1R->[$nn3-$j-1] = -$aim;
+ $fft2R->[$j-1] = $aip;
+ $fft2R->[$j] = -$rem;
+ $fft2R->[$nn2-$j-1] = $aip;
+ $fft2R->[$nn3-$j-1] = $rem;
+ }
+}
+
+#----------------------------------------------------------------------
+# Interface to @ants_
+#
+# Notes:
+# - N (number of complex samples) calculated as next larger pwr-of-two
+# if set to 0 on calling; otherwise set is used
+# - @ants_ padded with 0es to $N (deprecated in Hamming [1989])
+# - ditto initial and final missing values
+# - set ifnr to nan if input is purely real
+#
+#----------------------------------------------------------------------
+
+sub cFFT($$$) { return cFFT_bufR(\@ants_,@_); }
+
+sub cFFT_bufR($$$) # ($bufR, $rfnr, $ifnr, [$N]) => @coeff
+{
+ my($bufR,$fnr,$ifnr,$N) = @_;
+ my(@data,$i,$lastSet);
+
+ unless ($N) { # $N not set
+ for ($N=1; $N <= $#ants_; $N <<= 1) {} # next greater pwroftwo
+ &antsInfo("(fft.pl) N set to $N")
+ unless ($N == $#ants_+1);
+ }
+ for ($i=0; $i<$N && $i<=$#ants_; $i++) { # PAD
+ last if (numberp($bufR->[$i][$fnr]) &&
+ (isnan($ifnr) || numberp($bufR->[$i][$ifnr])));
+ $data[2*$i] = 0;
+ $data[2*$i+1] = 0;
+ }
+ $lastSet = $i - 1;
+ &antsInfo("(fft.pl) WARNING: $i initial non-numbers padded with 0es!!!"),
+ $padded=1 if ($i);
+ while ($i<$N && $i<=$#ants_) { # fill
+ $i++,next unless (numberp($bufR->[$i][$fnr]) && # skip non-numbers
+ (isnan($ifnr) || numberp($bufR->[$i][$ifnr])));
+ croak("$0: (fft.pl) $lastSet, $i can't handle missing values ($bufR->[$lastSet+1][$fnr])!\n")
+ if ($lastSet != $i-1); # missing values
+ $data[2*$i] = $bufR->[$i][$fnr]; # real
+ $data[2*$i+1] = isnan($ifnr) ? 0 : $bufR->[$i][$ifnr]; # imag
+ $lastSet = $i;
+ $i++;
+ }
+ &antsInfo("(fft.pl) WARNING: %d final non-numbers padded with 0es!!!",$i-$lastSet-1),
+ $padded=1 if ($i > $lastSet+1);
+ &antsInfo("(fft.pl) WARNING: padded with %d 0es to next pwr-of-two!!!",$N-$i),
+ $padded=1 if ($i < $N);
+ croak("$0: (fft.pl) refusing to pad with zeroes unless mean is removed (sorry)\n")
+ if ($padded && !$FFT_ALLOW_ZERO_PADDING);
+ $i = $lastSet + 1;
+ while ($i < $N) { # PAD
+ $data[2*$i] = 0;
+ $data[2*$i+1] = 0;
+ $i++;
+ }
+ return &FOUR1(-1,@data);
+}
+
+sub icFFT($$@) # ($ofnr, $tfnr, @coeff) => sigma
+{
+ my($ofnr,$tfnr,@coeff) = @_;
+ my($N) = ($#coeff+1)/2;
+ my(@val) = &FOUR1(1,@coeff);
+ my($i);
+ my($n) = 0;
+ my($sumsq) = 0;
+ my($mai) = 0;
+
+ for ($i=0; $i<$N && $i<=$#ants_ ; $i++) { # fill
+ my($oldval) = $ants_[$i][$ofnr];
+ push(@{$ants_[$i]},nan) # pad empty fields
+ while ($#{$ants_[$i]} < $tfnr);
+ $ants_[$i][$tfnr] = $val[2*$i]/$N; # real
+ $mai = abs($val[2*$i+1]) # imag
+ if (abs($val[2*$i+1]) > $mai);
+ next unless (numberp($oldval)); # sigma
+ $sumsq += ($oldval - $ants_[$i][$tfnr])**2;
+ $n++;
+ }
+ &antsInfo("(fft.pl) WARNING: imaginary exponents (abs <= $mai) ignored")
+ if ($mai > $PRACTICALLY_ZERO);
+ &antsInfo("(fft.pl) WARNING: reducing data (%d -> %d)",$#ants_+1,$N)
+ if ($i <= $#ants_);
+ while ($i <= $#ants_) {
+ $ants_[$i][$fnr] = nan;
+ $i++;
+ }
+ return ($n > 1) ? sqrt($sumsq/($n-1)) : nan;
+}
+
+#----------------------------------------------------------------------
+# Periodogram (p.421; (12.7.5) -- (12.7.6))
+#----------------------------------------------------------------------
+
+# Miscellaneous Notes:
+#
+# - there are N/2 + 1 values in the (unbinned) PSD (see NR)
+
+# Notes regarding the effects of zero padding:
+#
+# - using zero-padding on a time series where the mean is not removed
+# can result in TOTALLY DIFFERENT RESULTS, try it e.g. with
+# temperatures!!! (A moment's thought will reveal why)
+#
+# - Because the total power is normalized to the mean squared amplitude
+# 0-padded values depress the power; this was taken care of below by
+# normalizing the power by multiplying it with nrm=(nData+nZeroes)/nData;
+#
+# - this was checked using `avg -m' (in case of complex input the total
+# power is given by sqrt(Re**2+Im**2));
+#
+# - if zero-padding is used sqrt(nrm*P[0]) is mean value (done in [pgram])
+
+# Notes on interpreting the power spectrum (Hamming [1989] & NR):
+#
+# - the frequency spectrum encompasses the frequencies between 0 (the
+# mean value) and the Nyquist frequency (1 / (2 x sampling interval))
+#
+# - higher frequencies are aliased into the power spectrum in a mirrored
+# way (e.g. noise tends to (linearly?) approach zero as f goes to inft;
+# the downsloping spectrum `hits' the Nyquist frequency, turns around
+# and continues falling towards the zero frequency, where it gets mirrored
+# again => spectrum flattens towards Nyquist frequency
+#
+# - the sum over all P's (total power) is equal to the mean square value;
+# when one-sided spectra are used, P[0] and P[N/2] are counted doubly
+# and must be subtracted from the total; NB: the total power is reduced
+# if data are padded with 0es
+#
+# - sqrt(P[0]) is an estimate for the mean value which is only accurate
+# if no zero-padding is perfomed; removing the mean will
+# strongly change the spectrum near the origin which might
+# or might not be a good thing, depending on the physics behind it (e.g.
+# it makes sense to remove the mean if a power spectrum from a temperature
+# record is calculated but not if flow velocity is used).
+# Removing higher order trends will also affect the spectrum but not
+# in such a simple fashion. Note that the problem is mainly restricted
+# to cases where the signal is in the low frequency and thus affected
+# by the strong changes in the spectrum there.
+
+# Notes on the two-sided spectra:
+# - the power of the mean flow (sqrt(P[0])) is non-rotary. To have the sum
+# of both one-sided spectra equal the two-sided one, each one-sided
+# spectrum gets half of the total value.
+# - the same is true for the highest frequency; at the Nyquist frequency
+# every rotation is sampled exactly twice => polarization cannot be
+# determined (imagine a wheel with one spoke...)
+
+
+sub pgram_onesided(@) # $nData,@C -> return @P
+{
+ my($nData,@C) = @_;
+ my($N) = ($#C+1) / 2; # number of fourier comps
+ my($Pfac) = $N**(-2) * $N/$nData; # normalized to mean-sq amp
+ my($k,@P);
+
+ $P[0] = $Pfac * ($C[0]**2 + $C[1]**2); # calc periodogram
+ for ($k=1; $k<=$N/2-1; $k++) {
+ $P[$k] = $Pfac * ($C[2*$k]**2 + $C[2*$k+1]**2 +
+ $C[2*($N-$k)]**2 + $C[2*($N-$k)+1]**2);
+ }
+ $P[$N/2] = $Pfac * ($C[2*($N/2)]**2 + $C[2*($N/2)+1]**2);
+ return @P;
+}
+
+sub pgram_pos(@) # $nData,@C -> return @P
+{
+ my($nData,@C) = @_;
+ my($N) = ($#C+1) / 2; # number of fourier comps
+ my($Pfac) = $N**(-2) * $N/$nData; # normalized to mean-sq amp
+ my($k,@P);
+
+ $P[0] = 0.5 * $Pfac * ($C[0]**2 + $C[1]**2); # calc periodogram
+ for ($k=1; $k<=$N/2-1; $k++) {
+ $P[$k] = $Pfac * ($C[2*$k]**2 + $C[2*$k+1]**2);
+ }
+ $P[$N/2] = 0.5 * $Pfac * ($C[2*($N/2)]**2 + $C[2*($N/2)+1]**2);
+ return @P;
+}
+
+sub pgram_neg(@) # $nData,@C -> return @P
+{
+ my($nData,@C) = @_;
+ my($N) = ($#C+1) / 2; # number of fourier comps
+ my($Pfac) = $N**(-2) * $N/$nData; # normalized to mean-sq amp
+ my($k,@P);
+
+ $P[0] = 0.5 * $Pfac * ($C[0]**2 + $C[1]**2); # calc periodogram
+ for ($k=1; $k<=$N/2-1; $k++) {
+ $P[$k] = $Pfac * ($C[2*($N-$k)]**2 + $C[2*($N-$k)+1]**2);
+ }
+ $P[$N/2] = 0.5 * $Pfac * ($C[2*($N/2)]**2 + $C[2*($N/2)+1]**2);
+ return @P;
+}
+
+#------------------------------------------------------------------------
+# Current Ellipses (Emery and Thomson, 5.6.4.2 (Rotary Component Spectra)
+#------------------------------------------------------------------------
+
+# Notes on phase (ellipsis inclination) calculations:
+# - comparing equations 5.6.42 and 5.6.43 in E+T shows a sign
+# sign change of one of the terms (U_2k - V_1k in eqn 5.6.42a)
+# - for reasons of symmetry, this is unlikely to be correct
+# - in order to test this, I compared the M2 ellipses inclinations of
+# a tidal analysis of BBTRE instruments #1 & #3 with the output
+# and found that changing the sign in 5.6.43a brought the values
+# into agreement (#1: tidal analysis 155+-3, pgram -25; #3: 136+-5,
+# pgram -44)
+# - the changes are marked in the code by a (superfluous) + sign
+# - the sign change was later found to be consistent with the
+# tidal analysis package manual by MGG Foreman (p.11)
+
+sub phase_pos(@) # @C -> return @eps
+{
+ my(@C) = @_;
+ my($N) = ($#C+1) / 2; # number of fourier comps
+ my($k,@eps);
+
+ $eps[0] = 180 / $PI * atan2(+$C[1],$C[0]);
+ for ($k=1; $k<=$N/2-1; $k++) {
+ $eps[$k] = 180 / $PI * atan2(+$C[2*$k+1],$C[2*$k]);
+ }
+ $eps[$N/2] = 180 / $PI * atan2(+$C[2*($N/2)+1],$C[2*($N/2)]);
+ return @eps;
+}
+
+sub phase_neg(@) # @C -> return @P
+{
+ my(@C) = @_;
+ my($N) = ($#C+1) / 2; # number of fourier comps
+ my($k,@P);
+
+ $eps[0] = 180 / $PI * atan2(+$C[1],$C[0]);
+ for ($k=1; $k<=$N/2-1; $k++) {
+ $eps[$k] = 180 / $PI * atan2(+$C[2*($N-$k)+1],$C[2*($N-$k)]);
+ }
+ $eps[$N/2] = 180 / $PI * atan2(+$C[2*($N/2)+1],$C[2*($N/2)]);
+ return @eps;
+}
+
+#----------------------------------------------------------------------
+
+1;
new file mode 100644
--- /dev/null
+++ b/gaussj.pl
@@ -0,0 +1,113 @@
+#======================================================================
+# G A U S S J . P L
+# doc: Wed Feb 24 17:06:55 1999
+# dlm: Fri Jan 6 10:23:44 2012
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 46 0 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# GAUSSJ routine from Numerical Recipes adapted to ANTS
+
+# Notes:
+# - both @A and @B passed by ref
+
+# HISTORY:
+# Feb 24, 1999: - apparently created
+# Jul 19, 2001: - apparently fiddled
+# Jan 6, 2011: - added code to check for numericity of input
+
+sub gaussj($$)
+{
+ my($AR,$BR) = @_;
+ my($n) = $#{$AR};
+ my($m) = $#{$BR->[1]};
+ my(@indxc,@indxr,@ipiv);
+ my($i,$icol,$irow,$j,$k,$l,$ll);
+ my($big,$dum,$pivinv);
+ my($temp);
+
+# print(STDERR "n = $n, m = $m\n");
+# for ($i=1; $i<=$n; $i++) {
+# for ($j=1; $j<=$n; $j++) {
+# print(STDERR "A[$i][$j] = $AR->[$i][$j]\n");
+# }
+# }
+
+ &vector(\@indxc,1,$n);
+ &vector(\@indxr,1,$n);
+ &vector(\@ipiv, 1,$n);
+ for ($j=1; $j<=$n; $j++) { $ipiv[$j] = 0; }
+ for ($i=1; $i<=$n; $i++) {
+ $big = 0.0;
+ for ($j=1; $j<=$n; $j++) {
+ if ($ipiv[$j] != 1) {
+ for ($k=1; $k<=$n; $k++) {
+ if ($ipiv[$k] == 0) {
+ croak("GAUSSJ: non-numeric A[$j][$k]\n")
+ unless numberp($AR->[$j][$k]);
+ if (abs($AR->[$j][$k]) >= $big) {
+ $big = abs($AR->[$j][$k]);
+ $irow = $j;
+ $icol = $k;
+ }
+ } elsif ($ipiv[$k] > 1) {
+ croak("GAUSSJ: Singular Matrix-1");
+ }
+ }
+ }
+ }
+ ++($ipiv[$icol]);
+ if ($irow != $icol) {
+ for ($l=1; $l<=$n; $l++) {
+ $temp = $AR->[$irow][$l];
+ $AR->[$irow][$l] = $AR->[$icol][$l];
+ $AR->[$icol][$l] = $temp;
+ }
+ for ($l=1; $l<=$m; $l++) {
+ croak("GAUSSJ: non-numeric B[$irow][$l]\n")
+ unless numberp($BR->[$irow][$l]);
+ croak("GAUSSJ: non-numeric B[$icol][$l]\n")
+ unless numberp($BR->[$icol][$l]);
+ $temp = $BR->[$irow][$l];
+ $BR->[$irow][$l] = $BR->[$icol][$l];
+ $BR->[$icol][$l] = $temp;
+ }
+ }
+ $indxr[$i] = $irow;
+ $indxc[$i] = $icol;
+ if ($AR->[$icol][$icol] == 0.0) {
+ croak("GAUSSJ: Singular Matrix-2");
+ }
+ $pivinv = 1.0/$AR->[$icol][$icol];
+ $AR->[$icol][$icol] = 1.0;
+ for ($l=1; $l<=$n; $l++) {
+ $AR->[$icol][$l] *= $pivinv;
+ }
+ for ($l=1; $l<=$m; $l++) {
+ $BR->[$icol][$l] *= $pivinv;
+ }
+ for ($ll=1; $ll<=$n; $ll++) {
+ if ($ll != $icol) {
+ $dum = $AR->[$ll][$icol];
+ $AR->[$ll][$icol] = 0.0;
+ for ($l=1; $l<=$n; $l++) {
+ $AR->[$ll][$l] -= $AR->[$icol][$l]*$dum;
+ }
+ for ($l=1; $l<=$m; $l++) {
+ $BR->[$ll][$l] -= $BR->[$icol][$l]*$dum;
+ }
+ }
+ }
+ }
+ for ($l=$n; $l>=1; $l--) {
+ if ($indxr[$l] != $indxc[$l]) {
+ for ($k=1; $k<=$n; $k++) {
+ $temp = $AR->[$k][$indxr[$l]];
+ $AR->[$k][$indxr[$l]] = $AR->[$k][$indxc[$l]];
+ $AR->[$k][$indxc[$l]] = $temp;
+ }
+ }
+ }
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/lfit.pl
@@ -0,0 +1,102 @@
+#======================================================================
+# L F I T . P L
+# doc: Sat Jul 31 11:24:47 1999
+# dlm: Thu Jan 5 12:53:11 2012
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 19 60 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# LFIT routine from Numerical Recipes adapted to ANTS
+
+# HISTORY:
+# Jul 31, 1999: - manually converted from c-source
+# Aug 01, 1999: - changed funcs() interface
+# Sep 26, 1999: - made sure right version of covsrt is used
+# Jun 28, 2001: - re-added commented out code 'cause it's required
+# on some perl versions
+# Jan 5, 2012: - BUG: non-numeric x/y were not handled correctly;
+# this was only easily apparent when the last
+# record contained non-numeric values
+
+# Notes:
+# - x,y,sig are field numbers for data in $ants_
+# - funcs is passed the current index & xfnr instead of the x-value
+# - if sig is a negative number, -sig is used as constant input stddev
+# - @a, @ia, @covar, &funcs passed as refs
+# - chi square is returned
+
+require "$ANTS/nrutil.pl";
+require "$ANTS/covsrt.pl";
+require "$ANTS/gaussj.pl";
+
+sub lfit($$$$$$$)
+{
+ my($xfnr,$yfnr,$sig,$aR,$iaR,$covarR,$funcsR) = @_;
+
+ my($i,$j,$k,$l,$m,$mfit); # int
+ my($ym,$wt,$sum,$sig2i,$chisq); # float
+ my(@beta,@afunc); # float[]
+
+ &matrix(\@beta,1,$#{$aR},1,1);
+ &vector(\@afunc,1,$#{$aR});
+ for ($j=1; $j<=$#{$aR}; $j++) {
+ $mfit++ if ($iaR->[$j]);
+ }
+ croak("lfit: no parameters to be fitted") if ($mfit == 0);
+ for ($j=1; $j<=$mfit; $j++) { # REQUIRED FOR SOME PERL VERSIONS!!!
+ for ($k=1;$ k<=$mfit; $k++) {
+ $covarR->[$j][$k] = 0;
+ }
+ $beta[$j][1] = 0;
+ }
+ for ($i=0; $i<=$#ants_; $i++) {
+ next if ($antsFlagged[$i]);
+ next unless numberp($ants_[$i][$xfnr]) && numberp($ants_[$i][$yfnr]);
+ &$funcsR($i,$xfnr,\@afunc);
+ $ym = $ants_[$i][$yfnr];
+ if ($mfit < $#{$aR}) {
+ for ($j=1; $j<=$#{$aR}; $j++) {
+ $ym -= $aR->[$j]*$afunc[$j] if (!$iaR->[$j]);
+ }
+ }
+ if ($sig > 0) { # field number
+ $sig2i = 1.0/($ants_[$i][$sig]*$ants_[$i][$sig]);
+ } else { # const value
+ $sig2i = 1.0/($sig*$sig);
+ }
+ for ($j=0,$l=1; $l<=$#{$aR}; $l++) {
+ if ($iaR->[$l]) {
+ $wt = $afunc[$l]*$sig2i;
+ for ($j++,$k=0,$m=1; $m<=$l; $m++) {
+ $covarR->[$j][++$k] += $wt*$afunc[$m] if ($iaR->[$m]);
+ }
+ $beta[$j][1] += $ym*$wt;
+ }
+ }
+ }
+ for ($j=2; $j<=$mfit; $j++) {
+ for ($k=1;$k<$j;$k++) {
+ $covarR->[$k][$j] = $covarR->[$j][$k];
+# print(STDERR "covarR[$k][$j] = $covarR->[$k][$j]\n");
+ }
+ }
+ &gaussj($covarR,\@beta);
+ for ($j=0,$l=1;$l<=$#{$aR};$l++) {
+ $aR->[$l]=$beta[++$j][1] if ($iaR->[$l]);
+ }
+ for ($i=0; $i<=$#ants_; $i++) {
+ next if ($antsFlagged[$i]);
+ next unless numberp($ants_[$i][$xfnr]) && numberp($ants_[$i][$yfnr]);
+ &$funcsR($i,$xfnr,\@afunc);
+ for ($sum=0,$j=1; $j<=$#{$aR}; $j++) {
+ $sum += $aR->[$j]*$afunc[$j];
+ }
+ my($tmpval) = ($sig > 0) ?
+ ($ants_[$i][$yfnr] - $sum) / $ants_[$i][$sig] :
+ ($ants_[$i][$yfnr] - $sum) / -$sig;
+ $chisq += $tmpval * $tmpval;
+ }
+ &covsrt($covarR,$iaR);
+ return $chisq;
+}
+
new file mode 100644
--- /dev/null
+++ b/libCPT.pl
@@ -0,0 +1,108 @@
+#======================================================================
+# L I B C P T . P L
+# doc: Wed Nov 15 12:28:49 2000
+# dlm: Fri May 9 11:40:01 2008
+# (c) 2000 A.M. Thurnherr
+# uE-Info: 25 31 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Nov 15, 2000: - created
+# May 29, 2001: - made bg/fg numeric
+# May 31, 2001: - removed dummy bg val from all arrays
+# Dec 12, 2001: - clarified format errors
+# Jun 21, 2004: - relaxed cpt file format restrictions
+# - made cpt into a hash
+# - totally re-written
+# Jun 25, 2004: - return good value if $z equal upper cpt table limit
+# Jun 28, 2004: - added default color model
+# Jun 30, 2004: - renamed from libGMT.pl to libCPT.pl
+# Dec 1, 2005: - BUG: roundoff error
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+# Jul 24, 2006: - modified to use $PRACTICALLY_ZERONY
+# Aug 16, 2006: - BUG: last level was returned on value < first level
+# May 9, 2008: - adapted to GMT 4.3 (see also IMPLEMENTATION NOTES
+# in [mkCPT])
+
+#----------------------------------------------------------------------
+# CPT File Parsing
+#----------------------------------------------------------------------
+
+# NB: %CPT structure assumes RGB --- if the color model is really HSV,
+# field names are wrong.
+
+# %CPT
+# levels number of different color levels
+# color_model RGB or HSV
+# @from_z from values (z, RGB) for each level
+# @from_R
+# @from_G
+# @from_B
+# @to_z to values (z, RGB) for each level
+# @to_R
+# @to_G
+# @to_B
+# bg_R background vals
+# bg_G
+# bg_B
+# fg_R foreground vals
+# fg_G
+# fg_B
+# nan_R nan vals
+# nan_G
+# nan_B
+
+sub readCPT($)
+{
+ my($f) = @_;
+ my($flag,%CPT);
+
+ for ($CPT{levels}=0; <$f>;) {
+ $CPT{color_model} = $' if /^# COLOR_MODEL = /; chomp($CPT{color_model});
+ s/#.*//;
+ next if /^\s*$/;
+ my(@f) = split;
+ if ($f[0] eq 'B') {
+ $CPT{bg_R} = $f[1]; $CPT{bg_G} = $f[2]; $CPT{bg_B} = $f[3];
+ } elsif ($f[0] eq 'F') {
+ $CPT{bg_R} = $f[1]; $CPT{bg_G} = $f[2]; $CPT{bg_B} = $f[3];
+ } elsif ($f[0] eq 'N') {
+ $CPT{nan_R} = $f[1]; $CPT{nan_G} = $f[2]; $CPT{nan_B} = $f[3];
+ } else {
+ $CPT{from_z}[$CPT{levels}] = $f[0];
+ $CPT{from_R}[$CPT{levels}] = $f[1];
+ $CPT{from_G}[$CPT{levels}] = $f[2];
+ $CPT{from_B}[$CPT{levels}] = $f[3];
+ $CPT{to_z}[$CPT{levels}] = $f[4];
+ $CPT{to_R}[$CPT{levels}] = $f[5];
+ $CPT{to_G}[$CPT{levels}] = $f[6];
+ $CPT{to_B}[$CPT{levels}] = $f[7];
+ $CPT{levels}++;
+ }
+ }
+ $CPT{color_model} = 'RGB' unless defined($CPT{color_model});
+ croak("$0: color model $CPT{color_model} not implemented\n")
+ unless ($CPT{color_model} =~ '\+?RGB' || $CPT{color_model} =~ '\+?HSV');
+ return %CPT;
+}
+
+sub CPTlvl($%)
+{
+ my($z,%CPT) = @_;
+ my($l);
+
+ croak("$0: no valid CPT info\n")
+ unless ($CPT{levels} > 0);
+
+ return nan if isnan($z);
+
+ for ($l=0; $l<$CPT{levels}; $l++) {
+ return $l if ($CPT{from_z}[$l] <= $z && $z < $CPT{to_z}[$l]);
+ }
+ return $CPT{levels}-1
+ if (abs($z-$CPT{to_z}[$CPT{levels}-1]) < $PRACTICALLY_ZERO);
+ return -1 if ($z < $CPT{from_z}[0]);
+ return $CPT{levels};
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/libEOS83.pl
@@ -0,0 +1,652 @@
+#======================================================================
+# L I B E O S 8 3 . P L
+# doc: Mon Mar 8 08:22:05 1999
+# dlm: Thu Oct 6 11:44:00 2011
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 1 0 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# Perl Implementation of UNESCO Eqn of State 1983
+
+# Notes:
+# - copied from eos83calc.c which was in turn...
+# - copied from pexec_v4 (incl comments)
+# - only subset of functions implemented
+# - some attempt at cleaning up the code has been made
+# - pressures in dbar throughout
+# - no temperature scale assumed; set PARAM ITS=90|68
+# - T90*1.00024=T68
+# - check values calculated with T68
+# - no conductivity unit assumed; set PARAM cond.unit=S/p|mS/cm
+
+# HISTORY:
+# Mar 08, 1999: - translated by hand from krc
+# - added &alpha(), &beta(), &Rrho(), &TurnerAngle()
+# Mar 13, 1999: - cosmetic changes
+# Mar 14, 1999: - BUG NAN instead of NaN
+# Mar 21, 1999: - make $sigmaR optional in &sVolAnom()
+# Mar 31, 1999: - alias &potemp() = &theta(); &podens() = &sigma()
+# - added &temp() to calc in-situ from potemp
+# Sep 18, 1999: - parameter typechecking
+# Aug 28, 2000: - added PARAM T68 check
+# Aug 29, 2000: - forced temp_scale param check --- set to T68 or T90
+# Sep 25, 2000: - changed temp_scale to 68 or 90 (easier check)
+# - check for temp_scale during loading
+# Nov 07, 2000: - added &dynHt()
+# - strictified
+# Nov 13, 2000: - removed temp_scale check during loading (STUPID,
+# because PARAMs are only available after header
+# is read)
+# Feb 28, 2001: - added &rho(S,T,P)
+# Mar 28, 2001: - changed Rrho() to use podens
+# - optimized &theta() for P == Pref
+# Apr 2, 2001: - &TurnerAngle() disabled pending adaptation to new Rrho()
+# Apr 3, 2001: - updated &TurnerAngle()
+# Jul 17, 2001: - cosmetics
+# - added &grav(), &potErgAnom()
+# Jul 18, 2001: - cosmetics
+# Jul 20, 2001: - changed temp_scale to ITS
+# Nov 26, 2001: - added &g(), &f()
+# Dec 26, 2005: - update notes
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+# - nan must be quoted for use strict
+# Nov 5, 2006: - added K15toSalin
+# Oct 18, 2007: - adapted to new &antsFunUsage()
+# - changed order of &salin() params
+# Oct 19, 2007: - continued
+# - removed &grav(), podens(), potemp()
+# Dec 1, 2007: - made theta(), sigma(), rho() return nan on nan input
+# Dec 21, 2007: - BUG: grav() was still used
+# Jan 20, 2008: - BUG: theta(), sigma(), rho() still generated error on nan in
+# - made depth(), dynht(), potErgAnom() return nan on nan in
+# Jan 4, 2011: - maded salin(), sVel() return nan on nan in
+# Oct 6, 2011: - added %cond.unit (analogous to %ITS)
+
+require "$ANTS/libvec.pl";
+use strict;
+
+#======================================================================
+# PART I: stuff taken from PEXEC
+#======================================================================
+
+{ # BEGIN STATIC SCOPE
+
+ my($TCONV);
+
+ sub TCONV()
+ {
+ unless (defined($TCONV)) {
+ my($ITS) = &antsRequireParam('ITS');
+ if ($ITS == 68) {
+ $TCONV = 1;
+ } elsif ($ITS == 90) {
+ $TCONV = 1.00024;
+ } else {
+ croak("$0: illegal PARAM-value ITS=$ITS\n");
+ }
+ }
+ return $TCONV;
+ }
+
+} # END STATIC SCOPE
+
+#----------------------------------------------------------------------
+# ADIABATIC TEMPERATURE GRADIENT DEG C/BAR
+# REF: BRYDEN,H.,1973,DEEP-SEA RES.,20,401-408
+# CHECK VALUE: ATGR80=3.255976E-3 FOR S=40 NSU,T=40 DEG C,
+# PIN=10000 DECIBARS
+# NB: real check value appears to be 3.255976E-4; this makes sense
+# as check value of potential temperature below is correct. Also
+# note the 0.1 factor on return.
+#----------------------------------------------------------------------
+
+{ my(@fc);
+ sub adiaTempGrad(@)
+ {
+ my($S,$T,$P) = &antsFunUsage(3,'fff','[salin, temp, press(db)]',
+ \@fc,'salin','temp','press',@_);
+ my($DS);
+ my($TCONV) = &TCONV();
+
+ $T *= $TCONV; # use T68
+ $P *= 0.1;
+ $DS = $S - 35.0;
+ return 0.1 * ((((-2.1687E-13*$T+1.8676E-11)*$T-4.6206E-10)*$P
+ +((2.7759E-10*$T-1.1351E-8)*$DS+((-5.4481E-12*$T
+ +8.733E-10)*$T-6.7795E-8)*$T+1.8741E-6))*$P
+ +(-4.2393E-7*$T+1.8932E-5)*$DS
+ +((6.6228E-9*$T-6.836E-7)*$T+8.5258E-5)*$T+3.5803E-4) / $TCONV;
+ }
+}
+
+#----------------------------------------------------------------------
+# TO COMPUTE LOCAL POTENTIAL TEMPERATURE AT PR
+# USING BRYDEN 1973 POLYNOMIAL FOR ADIABATIC LAPSE RATE
+# AND RUNGE-KUTTA 4-TH ORDER INTEGRATION ALGORITHM.
+# REF: BRYDEN,H.,1973,DEEP-SEA RES.,20,401-408
+# FOFONOFF,N.,1977,DEEP-SEA RES.,24,489-491
+# CHECK VALUE: PTMP83 =36.89072 FOR S=40 NSU,T=40 DEG C,
+# P(MEASURED PRESSURE)=10000 DECIBARS,Pref=0 DECIBARS
+#----------------------------------------------------------------------
+
+{ my(@fc);
+ sub theta(@)
+ {
+ my($S,$T,$P,$Pref) =
+ &antsFunUsage(4,'....','[salin, temp, press(db),] refpress(db)',
+ \@fc,'salin','temp','press',undef,@_);
+ return 'nan' unless numberp($S) && numberp($T) && numberp($P);
+ my($H,$XK,$Q);
+ my($TCONV) = &TCONV();
+
+ return $T if ($P == $Pref);
+ $T *= $TCONV; # use T68
+ $H = $Pref - $P;
+ $XK = $H * &adiaTempGrad($S,$T/$TCONV,$P)*$TCONV;
+ $T += 0.5 * $XK;
+ $Q = $XK;
+ $P += 0.5 * $H;
+ $XK = $H * &adiaTempGrad($S,$T/$TCONV,$P)*$TCONV;
+ $T += 0.29289322 * ($XK-$Q);
+ $Q = 0.58578644*$XK + 0.121320344*$Q;
+ $XK = $H * &adiaTempGrad($S,$T/$TCONV,$P)*$TCONV;
+ $T += 1.707106781 * ($XK-$Q);
+ $Q = 3.414213562*$XK - 4.121320344*$Q;
+ $P += 0.5*$H;
+ $XK = $H * &adiaTempGrad($S,$T/$TCONV,$P)*$TCONV;
+ return ($T + ($XK-2.0*$Q)/6.0)/$TCONV;
+ }
+}
+
+# can't easily do default fields because theta field name is not unique
+sub temp(@)
+{
+ my($S,$T,$P,$Pref) =
+ &antsFunUsage(4,"ffff","salin, potemp, press(db), refpress(db)",@_);
+ return &theta($S,$T,$Pref,$P);
+}
+
+#----------------------------------------------------------------------
+# Calculation of specific volume anomaly
+# Gill (1982), p.215: - specific volume = inverse of density
+# - SVA referenced to same press, T=0, S=35
+#
+# *************************************************
+# *** USES EQUATION OF STATE FOR SEA WATER 1980 ***
+# *************************************************
+#
+# Check value. SVAN83=981.30210E-8, SIGMA=59.82037
+# for S=40, T=40, P=10000
+#
+# NB: - this one was a bitch to translate, used f2c and it shows :-)
+# - the 1e-8 factor in the check value is wrong; yup: see gill p.215
+# (typical units are 1e-8m^3kg^-1)
+# - check val appears to be slightly off, I get 981.30187319561
+#
+#----------------------------------------------------------------------
+
+sub sVolAnom(@)
+{
+ my($S,$T,$P,$sigmaR) =
+ &antsFunUsage(-3,'fff','salin, temp, press(db)[, ref to sigma var]',@_);
+ my($r3500) = 1028.1063;
+ my($r4) = 4.8314e-4;
+ my($dr350) = 28.106331;
+
+ my($temp0,$temp1,$temp2,$temp3,$temp4);
+ my($dvan,$dr35p,$p,$t,$dk,$pk,$sr,$gam,$sig,$rk35,$sva,$v350p);
+
+ my($TCONV) = &TCONV();
+
+ $t = $T*$TCONV; # use T68
+ $p = $P / 10.;
+# $sr = sqrt(abs($S));
+ $sr = sqrt($S);
+ $temp3 = (((($t * 6.536332e-9 - 1.120083e-6) * $t +
+ 1.001685e-4) * $t - .00909529) * $t + .06793952) * $t
+ - 28.263737;
+ $temp2 = ((($t * 5.3875e-9 - 8.2467e-7) * $t + 7.6438e-5)
+ * $t - .0040899) * $t + .824493;
+ $temp1 = ($t * -1.6546e-6 + 1.0227e-4) * $t - .00572466;
+ $sig = ($r4 * $S + $temp1 * $sr + $temp2) * $S + $temp3;
+ $v350p = 1. / $r3500;
+ $sva = -$sig * $v350p / ($r3500 + $sig);
+ $$sigmaR = $sig + $dr350 if (defined($sigmaR));
+ return $sva * 1e8 if ($p == 0.0);
+
+ $temp0 = ($t * 9.1697e-10 + 2.0816e-8) * $t - 9.9348e-7;
+ $temp1 = ($t * 5.2787e-8 - 6.12293e-6) * $t + 3.47718e-5;
+ $temp1 = $temp1 + $temp0 * $S;
+ $temp0 = 1.91075e-4;
+ $temp2 = ($t * -1.6078e-6 - 1.0981e-5) * $t + .0022838;
+ $temp3 = (($t * -5.77905e-7 + 1.16092e-4) * $t + .00143713) * $t - .1194975;
+ $temp3 = ($temp0 * $sr + $temp2) * $S + $temp3;
+ $temp0 = ($t * -5.3009e-4 + .016483) * $t + .07944;
+ $temp2 = (($t * -6.167e-5 + .0109987) * $t - .603459) * $t + 54.6746;
+ $temp4 = ((($t * -5.155288e-5 + .01360477) * $t - 2.327105) * $t + 148.4206) * $t - 1930.06;
+ $temp4 = ($temp0 * $sr + $temp2) * $S + $temp4;
+ $dk = ($temp1 * $p + $temp3) * $p + $temp4;
+ $rk35 = ($p * 5.03217e-5 + 3.359406) * $p + 21582.27;
+ $gam = $p / $rk35;
+ $pk = 1. - $gam;
+ $sva = $sva * $pk + ($v350p + $sva) * $p * $dk / ($rk35 * ($rk35 + $dk));
+ $v350p *= $pk;
+ $dr35p = $gam / $v350p;
+ $dvan = $sva / ($v350p * ($v350p + $sva));
+ $$sigmaR = $dr350 + $dr35p - $dvan if (defined($sigmaR));
+ return $sva * 1e8;
+}
+
+#----------------------------------------------------------------------
+# Dynamic Height (from dyht83.F)
+# Usage:
+# - dynHt(salin,temp,press[,idx])
+# Check Values from PEXEC:
+# - dynHt(40,18,20) -> -.01879
+# - dynHt(??,16,50) -> -.03194
+# - dynHt(??,14,100) -> -.00255
+# NB: - check values 2 & 3 do not appear to check out
+# - checked against WHOI-supplied BBTRE data indicates max
+# diff of 1e-3 dyn.m at 5141m
+# - use different idx to use multiple times in single program
+# (c.f. [gshear])
+# - behaves the same as the pexec version with PFIRST=0
+# - dynamic height seems to be defined (1e-5 factor) to allow
+# station distance to be in km and velocities in cm/s
+#----------------------------------------------------------------------
+
+{ # BEGIN static scope
+
+ my(@lastP,@lastAnom,@ht);
+
+ sub dynHt(@)
+ {
+ my($S,$T,$P,$idx) =
+ &antsFunUsage(-3,"...","salin, temp, press(db)[, <idx>]",@_);
+ return 'nan' unless numbersp($S,$T,$P);
+ my($anom) = sVolAnom($S,$T,$P) * 1e-5;
+
+ if (!defined($ht[$idx])) { # first call
+ $ht[$idx] = $P * $anom;
+ } else { # successive calls
+ croak("$0: pressure not increasing monotonically ($lastP[$idx] -> $P)\n")
+ if ($P < $lastP[$idx]);
+ $ht[$idx] += ($P-$lastP[$idx]) * ($anom+$lastAnom[$idx])/2;
+ }
+ $lastP[$idx] = $P; $lastAnom[$idx] = $anom;
+
+ return $ht[$idx];
+ }
+
+} # END static scope
+
+#----------------------------------------------------------------------
+# Local Gravity (from grav83.F)
+# Usage:
+# - g(press,lat)
+# Check Values:
+# - g(10000,30) = 9.804160
+#----------------------------------------------------------------------
+
+{ my(@fc);
+ sub g(@)
+ {
+ my($P,$lat) = &antsFunUsage(2,'ff','[press(db), lat]',\@fc,'press','%lat',@_);
+
+ my($x) = sin($lat/57.29578) ** 2;
+ my($g) = 9.780318*(1.0+(5.2788e-3+2.36e-5*$x)*$x); # global variation
+ return $g + 1.092e-6 * $P; # pressure correction
+ }
+}
+
+#----------------------------------------------------------------------
+# Coriolis frequency
+# Usage:
+# - f(%lat)
+#----------------------------------------------------------------------
+
+{ my(@fc);
+ sub f(@)
+ {
+ my($lat) = &antsFunUsage(1,'f','[lat]',\@fc,'%lat',@_);
+ my($Omega) = 7.292e-5; # Gill (1982)
+ return 2 * $Omega * sin(rad($lat));
+ }
+}
+
+#----------------------------------------------------------------------
+# Potential Energy Anomaly (from pean83.F)
+# Usage:
+# - potErgAnom(salin,temp,press,refPress,lat)
+# Check Values from PEXEC: (NB: sequence of calls)
+# - potErgAnom(40,18, 20,0,49.2235) = -1.91462
+# - potErgAnom(38,16, 50,0,49.2235) = -4.31092
+# - potErgAnom(36,14,100,0,49.2235) = 24.82922
+# Units:
+# - Gill (1982) p.45: m^2/s^2 = J/kg
+# NB:
+# - geopotential Phi is PEA wrt zero pressure
+# - PE of volume is volume integral of rho*PEA (c.f. Gill, p.80)
+# - check value lat calculated so that g(0,lat) ~ 9.81
+# - IF Pref<P ON 1ST CALL, HEIGHT WILL BE CALCULATED FROM LEVEL
+# Pref. HENCE IF Pref = 0.0, FROM SEA SURFACE DOWN.
+# - different to pexec, this version sets values for P<Pref to nan
+#----------------------------------------------------------------------
+
+{ # BEGIN STATIC SCOPE
+
+ my($gzero,$H,$lastZ,$lastP);
+
+ sub potErgAnom(@)
+ {
+ my($S,$T,$P,$Pref,$lat) =
+ &antsFunUsage(5,".....","salin, temp, press(db), refpress(db), lat",@_);
+ return 'nan' unless numbersp($S,$T,$P,$Pref,$lat);
+
+ return 'nan' if ($P < $Pref);
+
+ $gzero = g(0,$lat) unless (defined($gzero)); # 1st time
+ my($g) = $gzero + 1.113e-4*$P;
+
+ my($anom) = sVolAnom($S,$T,$P) * 1e-3;
+ my($Z) = $anom * $P/$g;
+
+ if (defined($H)) { # not 1st time
+ croak("$0: pressure not increasing monotonically\n")
+ if ($P < $lastP);
+ $H += ($Z+$lastZ) * ($P-$lastP)*0.5;
+ } else {
+ $H = (($anom*$Pref/$g)+$Z)*($P-$Pref)*0.5;
+ }
+
+ $lastP = $P; $lastZ = $Z;
+ return $H;
+ }
+
+} # END static scope
+
+#----------------------------------------------------------------------
+# Density at pressure P (P - Measured pressure)
+# (PREF - Reference pressure)
+# Equation of state for seawater proposed by JPOTS 1980
+# References
+# Millero et al 1980, Deep Sea Res.,27A,255-264
+# Jpots Ninth Report 1978, Tenth Report 1980
+# Units:
+# Pressure P Decibars
+# Temperature T Deg Celcius (IPTS-68)
+# Salinity S NSU (IPSS-78)
+# Density RHO KG/M**3
+# Spec. Vol. EOS80 M**3/KG
+# check value. 43.331642 for P=10000,PREF=5000,T=40,S=40
+# NB: check value appears to be 42.33164!!!
+#----------------------------------------------------------------------
+
+{ my(@fc);
+ sub sigma(@)
+ {
+ my($S,$T,$P,$Pref) =
+ &antsFunUsage(4,'....','[salin, temp, press(db),] refpress(db)',
+ \@fc,'salin','temp','press',undef,@_);
+ return 'nan' unless numberp($S) && numberp($T) && numberp($P);
+ my($sig);
+ &sVolAnom($S,&theta($S,$T,$P,$Pref),$Pref,\$sig);
+ return $sig;
+ }
+}
+
+{ my(@fc);
+ sub rho(@)
+ {
+ my($S,$T,$P) = &antsFunUsage(3,'...','[salin, temp, press(db)]',
+ \@fc,'salin','temp','press',@_);
+ return 'nan' unless numberp($S) && numberp($T) && numberp($P);
+ return 1000 + &sigma($S,$T,$P,$P);
+ }
+}
+
+#----------------------------------------------------------------------
+# FUNCTION TO CONVERT CONDUCTIVITY TO SALINITY ACCORDING TO THE
+# ALGORITHMS RECOMMMENDED BY JPOTS USING THE 1978 PRACTICAL
+# SALINITY SCALE (IPSS-78) AND IPTS-68 FOR TEMPERATURE.
+# C1535=CONDUCTIVITY (FROM CULKIN&SMITH,1980,J.OCEAN.ENG.VOL.5
+# PP22-23) = 42.9140 AT PRES=0.0,
+# SALINITY 35 NSU AND TEMPERATURE 15 DEG CELSIUS (IPTS-68)
+# PRESSURE=DECIBARS
+# RETURNS ZERO FOR CND<.0005
+# CHECKVALUES....
+# SAL83 =40.000000 FOR CND=81.025545,T=40 DEG C,PIN=10000
+# DECIBARS
+# WRITTEN BY N FOFONOFF; REVISED OCT 6 1980
+# FCN SAL83, XR=SQRT(RT)
+# DERIVATIVE WRT XR ; DSAL/DXR
+# RT35
+# C,B,A, POLYNOMIALS
+# NB: - done using f2c (couldn't be bothered)
+# - removed SAL->COND
+#----------------------------------------------------------------------
+
+{ my(@fc);
+ my($cond_scale); # 1 for mS/cm, 10 for S/m
+ sub salin(@)
+ {
+ my($C,$T,$P) = &antsFunUsage(3,'...','[cond, temp, press(db)]',
+ \@fc,'cond','temp','press',@_);
+ return 'nan' unless numberp($C) && numberp($T) && numberp($P);
+ my($r__,$dt,$rt,$c1535);
+ my($TCONV) = &TCONV();
+
+ unless (defined($cond_scale)) { # deal with different conductivity units
+ my($cu) = &antsRequireParam('cond.unit');
+ if ($cu eq 'S/m') { $cond_scale = 10; }
+ elsif ($cu eq 'mS/cm') { $cond_scale = 1; }
+ else { croak("$0: illegal PARAM-value cond.unit=$cu\n"); }
+ }
+ $C *= $cond_scale;
+
+ return 0.0 if ($C <= 5e-4); # zero salinity trap
+ $T *= $TCONV; # use T68 scale
+ $c1535 = 42.914;
+ $dt = $T - 15.0;
+ $P *= .1; # convert pressure to bars
+ $r__ = $C / $c1535; # convert cond to salin
+ $rt = $r__ / ((((($T * 1.0031e-9 - 6.9698e-7) * $T +
+ 1.104259e-4) * $T + .0200564) * $T + .6766097) * ((($P
+ * 3.989e-12 - 6.37e-8) * $P + 2.07e-4) * $P / (
+ ($T * 4.464e-4 + .03426) * $T + 1. + ($T *
+ -.003107 + .4215) * $r__) + 1.));
+ $rt = sqrt(abs($rt));
+ return (((($rt * 2.7081 - 7.0261) * $rt + 14.0941) *
+ $rt + 25.3851) * $rt - .1692) * $rt + .008 +
+ $dt / ($dt * .0162 + 1.) * ((((($rt * -.0144 +
+ .0636) * $rt - .0375) * $rt - .0066) * $rt -
+ .0056) * $rt + 5e-4);
+ }
+}
+
+#----------------------------------------------------------------------
+# K15toSalin; see http://ioc.unesco.org/oceanteacher/OceanTeacher2/01_GlobOcToday/02_CollDta/02_OcDtaFunda/03_T&SScales/TemperatureAndSalinityScales.htm
+#----------------------------------------------------------------------
+
+sub K15toSalin(@)
+{
+ my($K15) = &antsFunUsage(1,'f','K15',@_);
+ return 0.0080 - 0.1692 * $K15**0.5
+ + 25.3851 * $K15**1.0
+ + 14.0941 * $K15**1.5
+ - 7.0261 * $K15**2.0
+ + 2.7081 * $K15**2.5;
+}
+
+#----------------------------------------------------------------------
+# DEPTH IN METERS FROM PRESSURE IN DECIBARS USING
+# SAUNDERS AND FOFONOFF'S METHOD.
+# DEEP SEA RES., 1976,23,109-111.
+# FORMULA REFITTED FOR EOS80
+# CHECK VALUE. 9712.654 M FOR PIN=10000 DECIBARS,LATITUDE=30 DEG
+# ..CONVERT PRESSURE TO BARS
+# NB: results are closer to Saunders, JPO 11, 1981 than ref given
+# above. They are not exact, either, however.
+#----------------------------------------------------------------------
+
+{ my(@fc);
+ sub depth(@)
+ {
+ my($P,$lat) = &antsFunUsage(2,'..','[press(db), lat]',\@fc,'press','%lat',@_);
+ return 'nan' unless numbersp($P,$lat);
+ my($x) = sin($lat/57.29578);
+ $P *= 0.1;
+ $x = $x*$x;
+ return ((((-1.82E-11*$P+2.279E-7)*$P-2.2512E-3)*$P+97.2659)*$P) /
+ (9.780318*(1.0+(5.2788E-3+2.36E-5*$x)*$x) + 1.092E-5*$P);
+ }
+}
+
+#----------------------------------------------------------------------
+# Convert depth to pressure using 2nd order polynomial
+# From file pdepth.F (pexec)
+# This is based on Saunders, JPO 11, 1981
+#----------------------------------------------------------------------
+
+{ my(@fc);
+ sub press(@)
+ {
+ my($d,$lat) = &antsFunUsage(2,'ff','[depth, lat]',\@fc,'depth','%lat',@_);
+ my($c1) = 5.92E-3 + 5.25E-3 * sin($lat/57.29578) ** 2;
+ my($c2) = 2.21E-6;
+ my($press) = (1 - $c1 - sqrt((1 - $c1)**2 - 4*$d*$c2)) / (2*$c2);
+ my($derr) = abs(&depth($press,$lat) - $d);
+
+ &antsInfo("WARNING (libEOS83.pl): %.1gm depth error due to pressure " .
+ "approximation", $derr) if ($derr >= 1);
+ return $press;
+ }
+}
+
+#----------------------------------------------------------------------
+# SOUND SPEED SEAWATER (CHEN & MILLERO 1977, JASA,62,1129-1135)
+# SPEED IN M/S, P IN DECIBARS, T DEG C (IPTS-68), S NSU(IPSS-78)
+# CHECK VALUE : 1731.9954 M/S FOR PIN=10000, T=40, C,S=40
+# NB: - f2c used (because of fortran `equivalence')
+#----------------------------------------------------------------------
+
+{ my(@fc);
+ sub sVel(@)
+ {
+ my($S,$T,$P) = &antsFunUsage(3,'...','[salin, temp, press(db)]',
+ \@fc,'salin','temp','press',@_);
+ return 'nan' unless numberp($S) && numberp($T) && numberp($P);
+ my($temp0,$temp1,$temp2,$temp3);
+ my($a,$b,$c__,$d__,$sr);
+ my($TCONV) = &TCONV();
+
+ $T *= $TCONV; # T68
+ $P *= .1; # CONVERT PRESSURE TO BARS
+ $sr = sqrt(abs($S)); # S**2 TERM
+ $d__ = .001727 - $P * 7.9836e-6;
+ $temp1 = $T * 1.7945e-7 + 7.3637e-5; # S**3/2 TERM
+ $temp0 = -.01922 - $T * 4.42e-5;
+ $b = $temp0 + $temp1 * $P;
+ $temp3 = ($T * -3.389e-13 + 6.649e-12) * $T + 1.1e-10; # S**1 TERM
+ $temp2 = (($T * 7.988e-12 - 1.6002e-10) * $T + 9.1041e-9) * $T - 3.9064e-7;
+ $temp1 = ((($T * -2.0122e-10 + 1.0507e-8) * $T - 6.4885e-8) * $T
+ - 1.258e-5) * $T + 9.4742e-5;
+ $temp0 = ((($T * -3.21e-8 + 2.006e-6) * $T + 7.164e-5) * $T - .01262)
+ * $T + 1.389;
+ $a = (($temp3 * $P + $temp2) * $P + $temp1) * $P + $temp0;
+ $temp3 = ($T * -2.3643e-12 + 3.8504e-10) * $T - 9.7729e-9; # S**0 TERM
+ $temp2 = ((($T * 1.0405e-12 - 2.5335e-10) * $T + 2.5974e-8) * $T
+ - 1.7107e-6) * $T + 3.126e-5;
+ $temp1 = ((($T * -6.1185e-10 + 1.3621e-7) * $T - 8.1788e-6) * $T
+ + 6.8982e-4) * $T + .153563;
+ $temp0 = (((($T * 3.1464e-9 - 1.478e-6) * $T + 3.342e-4) * $T - .0580852)
+ * $T + 5.03711) * $T + 1402.388;
+ $c__ = (($temp3 * $P + $temp2) * $P + $temp1) * $P + $temp0;
+ return $c__ + ($a + $b * $sr + $d__ * $S) * $S; # SOUND SPEED RETURN
+ }
+}
+
+#======================================================================
+# PART II: Homegrown Stuff
+#======================================================================
+
+#----------------------------------------------------------------------
+# &alpha(S,T,P) linear thermal expansion coefficient
+# Notes: - use temperature interval of 0.2 degrees
+# - depth instead of pressure ok
+# Check Value: - alpha(35,2,6000) = 0.000209447279306853
+#----------------------------------------------------------------------
+
+sub alpha(@)
+{
+ my($S,$T,$P) = &antsFunUsage(3,"fff","salin, temp, press | depth",@_);
+ return (&sigma($S,$T-.1,$P,$P) - &sigma($S,$T+.1,$P,$P))
+ / (.2 * (1000+&sigma($S,$T,$P,$P)));
+}
+
+#----------------------------------------------------------------------
+# &beta(S,T,P) linear haline contraction coefficient
+# Notes: - use salinity interval of 0.02 psu
+# - depth instead of pressure ok
+# Check Value: - beta(35,2,6000) = 0.000718513652714652 (should check Gill)
+#----------------------------------------------------------------------
+
+sub beta(@)
+{
+ my($S,$T,$P) = &antsFunUsage(3,"fff","salin, temp, press | depth",@_);
+ return (&sigma($S+0.01,$T,$P,$P) - &sigma($S-0.01,$T,$P,$P))
+ / (.02 * (1000+&sigma($S,$T,$P,$P)));
+}
+
+#----------------------------------------------------------------------
+# &Rrho(midS,S0,S1,midT,T0,T1,midP,P0,P1) stability ratio
+# Notes: - depth instead of pressure ok
+# Check Value: - Rrho(35.05,35.1,35,4.27,4.82,3.72,2100,2100,2100) = 2.222
+#----------------------------------------------------------------------
+
+sub alphaDT(@)
+{
+ my($S,$T0,$T1,$P,$P0,$P1) = @_;
+# &antsFunUsage(6,"ffffff","S, T0, T1, P, P0, P1",@_);
+ my($sgn) = ($P1 > $P0) ? 1 : -1;
+ return $sgn * (&sigma($S,$T1,$P1,$P) - &sigma($S,$T0,$P0,$P));
+}
+
+sub betaDS(@)
+{
+ my($S0,$S1,$T,$P,$P0,$P1) = @_;
+# &antsFunUsage(6,"ffffff","S0, S1, T, P, P0, P1",@_);
+ my($sgn) = ($P1 > $P0) ? 1 : -1;
+ return $sgn * (&sigma($S0,$T,$P0,$P) - &sigma($S1,$T,$P1,$P));
+}
+
+sub Rrho(@)
+{
+ my($S,$S0,$S1,$T,$T0,$T1,$P,$P0,$P1) =
+ &antsFunUsage(9,"fffffffff","S, S0, S1, T, T0, T1, P, P0, P1",@_);
+ my($aDT) = &alphaDT($S,$T0,$T1,$P,$P0,$P1);
+ my($bDS) = &betaDS($S0,$S1,$T,$P,$P0,$P1);
+ return $bDS == 0 ? 'nan' : $aDT / $bDS;
+}
+
+#----------------------------------------------------------------------
+# &TurnerAngle(midS,S0,S1,midT,T0,T1,midP,P0,P1) Turner Angle
+# Notes: - c.f. &Rrho()
+# - -45<Tu<45 doubly stable
+# - Tu<-90, Tu>90 statically unstable
+# - 45<Tu<90 fingering regime
+# - -90<Tu<-45 diffusive regime
+# Check Value: TurnerAngle(35.05,35.1,35,4.27,4.82,3.72,2100,2100,2100.01) = 69.2296333539803
+#----------------------------------------------------------------------
+
+sub TurnerAngle(@)
+{
+ my($S,$S0,$S1,$T,$T0,$T1,$P,$P0,$P1) =
+ &antsFunUsage(9,"fffffffff","S, S0, S1, T, T0, T1, P, P0, P1",@_);
+ my($aDT) = &alphaDT($S,$T0,$T1,$P,$P0,$P1);
+ my($bDS) = &betaDS($S0,$S1,$T,$P,$P0,$P1);
+ return atan2($aDT+$bDS,$aDT-$bDS)*57.29577951;
+}
+
+1;
+
new file mode 100644
--- /dev/null
+++ b/libGM.pl
@@ -0,0 +1,84 @@
+#======================================================================
+# L I B G M . P L
+# doc: Sun Feb 20 14:43:47 2011
+# dlm: Sun Apr 1 11:29:53 2012
+# (c) 2011 A.M. Thurnherr
+# uE-Info: 53 1 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Feb 20, 2011: - created
+# Feb 28, 2011: - cosmetics
+# Mar 28, 2012: - BUG: N had been ignored (but only affects vertical
+# wavelengths > 1000m in any was significantly
+# - changed from Munk eqn 9.23b to 9.23a, which also
+# affects only long wavelengths
+# - return nan for omega outside internal-wave band
+# Mar 29, 2012: - re-wrote using definition of B(omega) from Munk (1981)
+
+require "$ANTS/libEOS83.pl";
+
+my($pi) = 3.14159265358979;
+
+#======================================================================
+# Vertical velocity spectral density
+#
+# Units: K.E. per frequency per wavenumber [m^2/s^2*1/s*1/m = m^3/s]
+# Version: GM79?
+#
+# E. Kunze (email, Feb 2011): The GM vertical velocity w spectrum is described by
+#
+# S[w](omega, k_z) = PI*E_0*b*{f*sqrt(omega^2-f^2)/omega}*{j*/(k_z + k_z*)^2}
+#
+# where E_0 = 6.3 x 10^-5 is the dimensionless spectral level, b = 1300 m is
+# the pycnocline lengthscale, j* = 3 the peak mode number and k_z* the
+# corresponding vertical wavenumber. The flat log-log spectrum implies w is
+# dominated by near-N frequencies (where we know very little though Yves
+# Desaubies wrote some papers back in the late 70's/early 80's about the
+# near-N peak) and low modes. The rms w = 0.6 cm/s, right near your noise
+# level. Interestingly, the only N dependence is in m and m*. As far
+# as I know, little is known about its intermittency compared to horizontal
+# velocity. Since w WKB-scales inversely with N, the largest signals should
+# be in the abyss where you therefore likely have the best chance of
+# measuring it.
+#======================================================================
+
+sub m($$) # vertical wavenumber as a function of mode number & stratification params
+{
+ my($j,$N,$omega) = @_;
+
+ my($b) = 1300; #m # stratification e-folding scale (Munk 81)
+ my($N0) = 5.2e-3; #rad/s # extrapolated to surface value (Munk 81)
+
+# print(STDERR "omega = $omega, N = $N\n");
+ return defined($omega)
+ ? $pi / $b * sqrt(($N**2 - $omega**2) / ($N0**2 - $omega**2)) * $j
+ : $pi * $j * $N / ($b * $N0); # valid, except in vicinity of buoyancy turning frequency (p. 285)
+}
+
+sub B($) # structure function (omega dependence)
+{ # NB: f must be defined
+ my($omega) = @_;
+ croak("coriolis parameter not defined\n")
+ unless defined($f);
+ return 2 / $pi * $f / $omega / sqrt($omega**2 - $f**2);
+}
+
+
+sub Sw($$$$)
+{
+ my($omega,$m,$lat,$N) = &antsFunUsage(4,'fff','<frequency[1/s]> <vertical wavenumber[1/m]> <lat[deg]> <N[rad/s]>',@_);
+
+ local($f) = abs(&f($lat));
+ return nan if ($omega < $f || $omega > $N);
+
+ my($E0) = 6.3e-5; # dimensionless spectral level
+ my($j_star) = 3; # peak mode number
+ my($b) = 1300; #m # pycnocline lengthscale
+
+ my($mstar) = &m($j_star,$N,$omega);
+
+ return $E0 * $b * 2 * $f**2/$omega**2/B($omega) * $j_star / ($m+$mstar)**2;
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/libLADCP.pl
@@ -0,0 +1,116 @@
+#======================================================================
+# L I B L A D C P . P L
+# doc: Wed Jun 1 20:38:19 2011
+# dlm: Wed Jan 18 18:46:33 2012
+# (c) 2011 A.M. Thurnherr
+# uE-Info: 103 19 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Jun 1, 2011: - created
+# Jul 29, 2011: - improved
+# Aug 10, 2011: - made correct
+# Aug 11, 2011: - added "convenient combinations"
+# Aug 18, 2011: - made buoyancy frequency non-constant in S()
+# Jan 4, 2012: - improved T_VI to allow correcting even without superensembles
+# Jan 5, 2012: - removed S(), which is just pwrdens/N^2 (rather than
+# pwrdens/N^2/(2pi) as I erroneously thought)
+# Jan 18, 2012: - added T_VI_alt() to allow assessment of tilt correction extrema
+
+require "$ANTS/libvec.pl";
+require "$ANTS/libfuns.pl";
+
+#----------------------------------------------------------------------
+# Polzin et al., JAOT 2002 LADCP shear corrections
+#----------------------------------------------------------------------
+
+# NOTES:
+# - apply to downcast data only
+
+#----------------------------------------------------------------------
+# individual corrections
+#----------------------------------------------------------------------
+
+# NB: Dzb = (Dzt == Dzr) assumed
+
+sub T_ravg($$)
+{
+ my($kz,$Dzb) =
+ &antsFunUsage(2,'ff','<vertical wavenumber[rad/s]> <pulse/bin-length[m]>',@_);
+ return 1 / sinc($kz*$Dzb/2/$PI)**4;
+}
+
+
+sub T_fdiff($$)
+{
+ my($kz,$Dzd) =
+ &antsFunUsage(2,'ff','<vertical wavenumber[rad/s]> <differencing interval[m]>',@_);
+ return 1 / sinc($kz*$Dzd/2/$PI)**2;
+}
+
+
+sub T_interp($$$)
+{
+ my($kz,$Dzb,$Dzg) =
+ &antsFunUsage(3,'fff','<vertical wavenumber[rad/s]> <bin length[m]> <grid resolution[m]>',@_);
+ return 1 / sinc($kz*$Dzb/2/$PI)**4 / sinc($kz*$Dzg/2/$PI)**2;
+}
+
+
+# NB: Polzin et al claim that Dz should be ADCP bin size, which does not seem to make sense
+sub T_binavg($$)
+{
+ my($kz,$Dzg) =
+ &antsFunUsage(2,'ff','<vertical wavenumber[rad/s]> <grid resolution[m]>',@_);
+ return 1 / sinc($kz*$Dzg/2/$PI)**2;
+}
+
+
+sub T_tilt($$)
+{
+ my($kz,$dprime) =
+ &antsFunUsage(2,'ff','<vertical wavenumber[rad/s]> <d-prime[m]>',@_);
+ return 1 / sinc($kz*$dprime/2/$PI)**2;
+}
+
+#----------------------------------------------------------------------
+# convenient combinations
+#----------------------------------------------------------------------
+
+sub LADCP_tilt_dprime($)
+{
+ return -1.2 + 0.0857 * $_[0] - 0.000136 * $_[0]**2;
+}
+
+sub T_UH($$$$)
+{
+ my($kz,$blen,$grez,$maxrange) =
+ &antsFunUsage(4,'ffff','<vertical wavenumber[rad/s]> <ADCP bin size[m]> <shear grid resolution[m]> <max range[m]>',@_);
+ return T_ravg($kz,$blen) * T_fdiff($kz,$blen) * T_interp($kz,$blen,$grez) * T_tilt($kz,LADCP_tilt_dprime($maxrange));
+}
+
+sub T_SM($$$$)
+{
+ my($kz,$blen,$grez,$maxrange) =
+ &antsFunUsage(4,'ffff','<vertical wavenumber[rad/s]> <ADCP bin size[m]> <shear grid resolution[m]> <max range[m]>',@_);
+ return T_ravg($kz,$blen) * T_fdiff($kz,$blen) * T_binavg($kz,$grez) * T_tilt($kz,LADCP_tilt_dprime($maxrange));
+}
+
+sub T_VI($$$$$)
+{
+ my($kz,$blen,$sel,$grez,$maxrange) =
+ &antsFunUsage(5,'ff.ff','<vertical wavenumber[rad/s]> <ADCP bin size[m]> <superensemble size[m]|nan> <shear grid resolution[m]> <max range[m]>',@_);
+ return T_VI_alt($kz,$blen,$sel,$grez,LADCP_tilt_dprime($maxrange));
+}
+
+sub T_VI_alt($$$$$)
+{
+ my($kz,$blen,$sel,$grez,$dprime) =
+ &antsFunUsage(5,'ff.ff','<vertical wavenumber[rad/s]> <ADCP bin size[m]> <superensemble size[m]|nan> <shear grid resolution[m]> <tilt d-prime[m]>',@_);
+ croak("$0: tilt-dprime outside range [0..$blen]\n")
+ unless ($dprime>=0 && $dprime<=$blen);
+ return ($sel>0) ? T_ravg($kz,$blen) * T_binavg($kz,$sel) * T_binavg($kz,$grez) * T_tilt($kz,$dprime)
+ : T_ravg($kz,$blen) * T_binavg($kz,$grez) * T_tilt($kz,$dprime);
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/libNODC.pl
@@ -0,0 +1,130 @@
+#======================================================================
+# L I B N O D C . P L
+# doc: Mon Aug 28 11:07:47 2000
+# dlm: Sun Jul 2 00:16:26 2006
+# (c) 2000 A.M. Thurnherr
+# uE-Info: 117 0 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Aug 28, 2000: - created
+# Sep 05, 2000: - allow spaces instead of 0es in lat/lon to accomodate
+# for Talley's OCEANUS 24S files
+# Oct 16, 2000: - added &DD[D]MMSSh2d()
+# Feb 28, 2001: - changed &depth to &obs_depth to remove clash with
+# [libEOS83]
+# Aug 1, 2001: - BUG: obs() could not handle Reid and Mantyla -ve values
+# correctly (such as -80 with precision 3!)
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+
+require "$ANTS/libconv.pl";
+
+#----------------------------------------------------------------------
+# Lat/Lon
+#----------------------------------------------------------------------
+
+sub DDMMXh2d(@) # NODC SD2 header info
+{
+ my($DDMMX,$H) = &antsFunUsage(2,"51","DDMMX H",@_);
+ $DDMMX =~ s/ /0/g;
+ return &dmh2d(substr($DDMMX,0,2),
+ substr($DDMMX,2,2) . "." . substr($DDMMX,4,1),
+ $H);
+}
+
+sub DDDMMXh2d(@) # NODC SD2 header info
+{
+ my($DDDMMX,$H) = &antsFunUsage(2,"61","DDDMMX H",@_);
+ $DDDMMX =~ s/ /0/g;
+ return &dmh2d(substr($DDDMMX,0,3),
+ substr($DDDMMX,3,2) . "." . substr($DDDMMX,5,1),
+ $H);
+}
+
+sub DDMMSSh2d(@) # NODC detailed inventory info
+{
+ my($DDMMSS,$H) = &antsFunUsage(2,"61","DDMMSS H",@_);
+ $DDMMSS =~ s/ /0/g;
+ return &dmsh2d(substr($DDMMSS,0,2),
+ substr($DDMMSS,2,2),
+ substr($DDMMSS,4,2),
+ $H);
+}
+
+sub DDDMMSSh2d(@) # NODC detailed inventory info
+{
+ my($DDDMMSS,$H) = &antsFunUsage(2,"71","DDDMMSS H",@_);
+ $DDDMMSS =~ s/ /0/g;
+ return &dmsh2d(substr($DDDMMSS,0,3),
+ substr($DDDMMSS,3,2),
+ substr($DDDMMSS,5,2),
+ $H);
+}
+
+#----------------------------------------------------------------------
+# date/time
+#----------------------------------------------------------------------
+
+sub YYMMDD(@) # 6 digit date
+{
+ my($YYMMDD) = &antsFunUsage(1,"6","YYMMDD",@_);
+ return substr($YYMMDD,2,2) . "/" .
+ substr($YYMMDD,4,2) . "/19" . substr($YYMMDD,0,2);
+}
+
+sub HHt(@) # 3 digits (hours to tenths)
+{
+ my($HHt) = &antsFunUsage(1,"3","HHt",@_);
+ return sprintf("%02d:%02d",substr($HHt,0,2),substr($HHt,2,1)*6);
+}
+
+#----------------------------------------------------------------------
+# depth
+#----------------------------------------------------------------------
+
+sub obs_depth(@) # good depth only
+{
+ my($obs,$quality,$t_flag) =
+ &antsFunUsage(3,"c..","obs quality t_flag",@_);
+ return (isnan($quality) && ($t_flag ne 'T'))
+ ? $obs : nan;
+}
+
+sub wire_out(@) # wire-out
+{
+ my($obs,$quality,$t_flag) =
+ &antsFunUsage(3,"c..","obs quality t_flag",@_);
+ return (($quality == 6) && ($t_flag ne 'T'))
+ ? $obs : nan;
+}
+
+sub t_depth(@) # good thermometric depth
+{
+ my($obs,$quality,$t_flag) =
+ &antsFunUsage(3,"c..","obs quality t_flag",@_);
+ return (isnan($quality) && ($t_flag eq 'T'))
+ ? $obs : nan;
+}
+
+#----------------------------------------------------------------------
+# temp, salin, O2, ...
+#----------------------------------------------------------------------
+
+sub obs(@)
+{
+ my($obs,$prec,$qual) =
+ &antsFunUsage(3,".1.","obs prec qual",@_);
+ return nan if isnan($obs);
+ return nan if isnan($qual); # spc->nan==OK
+
+ my($fac) = 1; # Reid and Mantyla weird fmt
+ if ($obs =~ /^-/) {
+ $fac = -1;
+ $obs = $';
+ }
+ $obs = sprintf("%0${prec}d",$obs); # pre-pad missing 0es
+ substr($obs,-$prec,0) = "."; # PERL is wonderful...
+ return $fac * $obs;
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/libPOSIX.pl
@@ -0,0 +1,13 @@
+#======================================================================
+# L I B P O S I X . P L
+# doc: Mon Mar 8 11:46:36 1999
+# dlm: Mon Jul 9 12:26:12 2001
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 12 0 NIL 0 0 72 0 2 4 NIL ofnI
+#======================================================================
+
+# POSIX.pl library stub to allow -L option
+
+use POSIX;
+
+1;
new file mode 100644
--- /dev/null
+++ b/libRWalk.pl
@@ -0,0 +1,29 @@
+#======================================================================
+# L I B R W A L K . P L
+# doc: Tue Oct 5 21:34:37 2010
+# dlm: Tue Oct 5 21:47:28 2010
+# (c) 2010 A.M. Thurnherr
+# uE-Info: 26 26 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+sub fac($)
+{ return ($_[0] < 2) ? $_[0] : $_[0]*fac($_[0]-1); }
+
+#----------------------------------------------------------------------
+# From: http://mathworld.wolfram.com/RandomWalk1-Dimensional.html
+# Let N steps of equal length be taken along a line. Let p be the
+# probability of taking a step to the right, q the probability of taking a
+# step to the left, n1 the number of steps taken to the right, and n2 the
+# number of steps taken to the left.
+# The following calculates the probability of taking exactly n1 steps out
+# of N (= n1+n2) to the right.
+#----------------------------------------------------------------------
+
+sub pNSteps(@)
+{
+ my($n1,$N,$p,$q) = @_;
+ $p = $q = 0.5 unless defined($p);
+ return fac($n1+($N-$n1)) / (fac($n1)*fac($N-$n1)) * $p**$n1 * $q**($N-$n1);
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/libWOCE.pl
@@ -0,0 +1,71 @@
+#======================================================================
+# L I B W O C E . P L
+# doc: Mon Aug 28 11:07:47 2000
+# dlm: Thu Dec 10 13:43:44 2009
+# (c) 2000 A.M. Thurnherr
+# uE-Info: 31 33 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Sep 04, 2000: - created from [libNODC.pl]
+# Sep 19, 2000: - added &q_OK()
+# Jan 2, 2002: - added optional length argument to &q_OK()
+# - allowed NaN observations in &q_OK()
+# Aug 14, 2002: - added &csv_q_OK()
+# Jun 19, 2004: - made Y2K compatible
+# Apr 4, 2006: - added flt_qual(), flt_src()
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+# Dec 10, 2009: - adapted to netCDF processing
+
+require "$ANTS/libconv.pl"; # imply lat/lon conversions
+
+#----------------------------------------------------------------------
+# date/time
+#----------------------------------------------------------------------
+
+sub YYYYMMDD(@) # 8 digit date
+{
+ my($YYYYMMDD) = &antsFunUsage(1,"8","YYYYMMDD",@_);
+ return substr($YYYYMMDD,4,2) . '/' .
+ substr($YYYYMMDD,6,2) . '/' .
+ substr($YYYYMMDD,0,4);
+}
+
+sub HHMM(@) # 4 digits
+{
+ $_[0] = sprintf('%04d',$_[0]) if (@_ > 0); # pre-pad with 0es
+ my($HHMM) = &antsFunUsage(1,"4","HHMM",@_);
+ return substr($HHMM,0,2) . ":" . substr($HHMM,2,2);
+}
+
+#----------------------------------------------------------------------
+# CTD quality flags
+#----------------------------------------------------------------------
+
+sub q_OK(@) # exchange-format version (single flags)
+{
+ return $_[1] == 2 ? $_[0] : nan;
+}
+
+#----------------------------------------------------------------------
+# Float Quality/Source Flags [/Data/Floats/DBE/WFDAC/WDBE/quality.doc]
+# - 2-digit decimal number
+# - 10s: quality (0-9, with 9 being best)
+# - 1s: source:
+# 0 missing
+# 1 interpolated (backward diff for u/v)
+# 2 (forward diff for u/v)
+# 3 splined
+# 4 manually edited
+# 5 filtered/averaged
+# 9 original value
+# - should accept source values >= 4
+#----------------------------------------------------------------------
+
+sub flt_qual($)
+{ return int($_[0] / 10); }
+
+sub flt_src($)
+{ return $_[0] % 10; }
+
+1;
new file mode 100644
--- /dev/null
+++ b/libWOCE_oldstyle.pl
@@ -0,0 +1,77 @@
+#======================================================================
+# L I B W O C E . P L
+# doc: Mon Aug 28 11:07:47 2000
+# dlm: Sun Jul 2 00:16:46 2006
+# (c) 2000 A.M. Thurnherr
+# uE-Info: 53 35 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Sep 04, 2000: - created from [libNODC.pl]
+# Sep 19, 2000: - added &q_OK()
+# Jan 2, 2002: - added optional length argument to &q_OK()
+# - allowed NaN observations in &q_OK()
+# Aug 14, 2002: - added &csv_q_OK()
+# Jun 19, 2004: - made Y2K compatible
+# Apr 4, 2006: - added flt_qual(), flt_src()
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+
+require "$ANTS/libconv.pl"; # imply lat/lon conversions
+
+#----------------------------------------------------------------------
+# date/time
+#----------------------------------------------------------------------
+
+sub MMDDYY(@) # 6 digit date
+{
+ my($MMDDYY) = &antsFunUsage(1,"6","MMDDYY",@_);
+ my($YY) = substr($MMDDYY,4,2);
+ return substr($MMDDYY,0,2) . "/" .
+ substr($MMDDYY,2,2) . ($YY>50 ? "/19$YY" : "/20$YY");
+}
+
+sub HHMM(@) # 4 digits
+{
+ my($HHMM) = &antsFunUsage(1,"4","HHMM",@_);
+ return substr($HHMM,0,2) . ":" . substr($HHMM,2,2);
+}
+
+#----------------------------------------------------------------------
+# CTD quality flags
+#----------------------------------------------------------------------
+
+sub q_OK(@) # accept only perfect measurements (table 4.10)
+{
+ my($nflags) = (@_ == 3) ? 4 : $_[3];
+ my($obs,$qf,$qi) =
+ &antsFunUsage(-3,".${nflags}c","obs, quality flags, flag index[, nflags]",@_);
+ return (substr($qf,$qi,1) == 2) ? $obs : nan;
+}
+
+sub csv_q_OK(@) # exchange-format version (single flags)
+{
+ return $_[1] == 2 ? $_[0] : nan;
+}
+
+#----------------------------------------------------------------------
+# Float Quality/Source Flags [/Data/Floats/DBE/WFDAC/WDBE/quality.doc]
+# - 2-digit decimal number
+# - 10s: quality (0-9, with 9 being best)
+# - 1s: source:
+# 0 missing
+# 1 interpolated (backward diff for u/v)
+# 2 (forward diff for u/v)
+# 3 splined
+# 4 manually edited
+# 5 filtered/averaged
+# 9 original value
+# - should accept source values >= 4
+#----------------------------------------------------------------------
+
+sub flt_qual($)
+{ return int($_[0] / 10); }
+
+sub flt_src($)
+{ return $_[0] % 10; }
+
+1;
new file mode 100644
--- /dev/null
+++ b/libconv.pl
@@ -0,0 +1,566 @@
+#======================================================================
+# L I B C O N V . P L
+# doc: Sat Dec 4 13:03:49 1999
+# dlm: Tue Apr 17 10:34:41 2012
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 61 76 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Dec 12, 1999: - created for the Rainbow CM data as libdate
+# Jul 07, 2000: - renamed to libconv and added lat/lon conversions
+# Aug 21, 2000: - added &s2d()
+# Aug 24, 2000: - added &DDMMXh2d() and &DDDMMXh2d()
+# Aug 28, 2000: - moved &DDMMXh2d() and &DDDMMXh2d() to [libNODC.pl]
+# Sep 04, 2000: - added &GMT2d()
+# Sep 20, 2000: - added &fmtdate(), &fmttime()
+# Oct 16, 2000: - added &dmsh2d()
+# Oct 31, 2000: - added &T90(), &T68()
+# Jan 22, 2001: - BUG: &GMT2d() wrongly +ve-ized stuff like -00:05
+# Feb 28, 2001: - added &O2mlpl2umpkg()
+# Aug 3, 2001: - made &O2mlpl2umpkg() return NaN on -ve input
+# Aug 7, 2001: - added &O2umpkg2mlpl()
+# - replaced temp_scale by ITS
+# Aug 8, 2001: - BUG: allowed for NaN O2 values
+# Aug 19, 2001: - change temp-conversions to allow nop; changed names
+# Sep 1, 2001: - BUG: allow for nan in addition to NaN
+# Dec 30, 2001: - generalized s2d()
+# - BUG: allow NaNs on temp conversions
+# Feb 4, 2002: - allow for -ve O2 values in conversions to handle offsets
+# Aug 14, 2002: - moved ITS checks in ITS_68() & ITS_90()
+# Oct 9, 2002: - added &fmttime1(),&fmtdate1()
+# Jan 23, 2003: - added more time conversion routines
+# Apr 14, 2003: - removed antsReplaceParam() call
+# May 21, 2004: - added ``-'' as a valid date separator
+# Jun 22, 2004: - added HSV2RGB()
+# Jun 27, 2004: - renamed degree-conversion routines
+# - added wraplon()
+# Dec 1, 2005: - cosmetics
+# Dec 9, 2005: - Version 3.2 [HISTORY]
+# Apr 4, 2006: - made epoch optional in &dayNo()
+# Apr 28, 2006: - added &dn2date()
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+# Nov 9, 2006: - added dec_time()
+# - added dn2date_time()
+# - moved year forward in dn2date()
+# Oct 17, 2007: - dn2date -> Date
+# - dn2date_time -> Time
+# - adapted Date/Time to antsFunUsage() with default fields
+# Oct 19, 2007: - removed antsFunUsage() from non-UI funs
+# Nov 17, 2007: - added "." as another legal date separator
+# Jul 10, 2008: - added support for month names in dayNo()
+# Dec 1, 2008: - added dec_time_long()
+# Dec 3, 2008: - renamed many of the date-conversion routines
+# - added frac_day()
+# Jan 8, 2009: - BUG: &Date() returned wrong date for any time after
+# midnite on last day of a month
+# Oct 27, 2010: - added &day_secs()
+# Jan 3, 2010: - extended frac_day() to allow a single string time-spec
+# Jul 19, 2011: - made epoch aptional in mmddyy2dec_time()
+# Aug 2, 2011: - enhanced yymmdd2dec_time()
+# Apr 17, 2012: - added space as another date separator in ddmmyy2dec_time
+
+require "$ANTS/libEOS83.pl"; # &sigma()
+require "$ANTS/libPOSIX.pl"; # &floor()
+require "$ANTS/libstats.pl"; # &min(),&max()
+
+#----------------------------------------------------------------------
+# Date Conversion
+#----------------------------------------------------------------------
+
+sub leapYearP(@) # leap year?
+{
+ my($y) = @_;
+
+ $y += ($y < 50) ? 2000 : 1900 if ($y < 100); # Y2K
+
+ return 0 if ($y%4 != 0);
+ return 1 if ($y%100 != 0);
+ return 0 if ($y%400 > 0);
+ return 1;
+}
+
+sub monthLength(@) # #days in given month/year
+{
+ my($y,$m) = @_;
+
+ return 31 if ($m==1 || $m==3 || $m==5 || $m==7 ||
+ $m==8 || $m==10 || $m==12);
+ return 30 if ($m==4 || $m==6 || $m==9 || $m==11);
+ return 28 + &leapYearP($y) if ($m == 2);
+ croak("$0: &monthLength(): Illegal month\n");
+}
+
+{ my(@fc);
+
+ sub Date(@) # day number -> date
+ {
+
+ my($dnf); # find std dn field & epoch
+ if (@_ == 0) {
+ for (my($i)=0; $i<@antsLayout; $i++) {
+ next unless ($antsLayout[$i] =~ /^dn(\d\d)$/);
+ $dnf = $antsLayout[$i]; push(@_,$1);
+ last;
+ }
+ }
+
+ my($year,$day) = &antsFunUsage(2,"cf","epoch, dayNo",\@fc,undef,$dnf,@_);
+
+ $year += ($year < 50) ? 2000 : 1900 # Y2K
+ if ($year < 100);
+
+ $day = int($day); # prevent runover on last day of month
+ while ($day > 365+&leapYearP($year)) { # adjust year
+ $day -= 365 + &leapYearP($year);
+ $year++;
+ }
+
+ my($month) = 1;
+ while ($day > &monthLength($year,$month)) {
+ $day -= &monthLength($year,$month);
+ $month++;
+ }
+
+ return sprintf('%04d/%02d/%02d',$year,$month,$day);
+ }
+}
+
+{ my(@fc);
+
+ sub Time(@) # day number -> date/time
+ {
+ my($dnf); # find standard dn field
+ for (my($i)=0; $i<@antsLayout; $i++) {
+ next unless ($antsLayout[$i] =~ /^dn\d\d$/);
+ $dnf = $antsLayout[$i];
+ last;
+ }
+
+ my($fday) = &antsFunUsage(1,"f","dayNo",\@fc,$dnf,@_);
+ my($day) = int($fday);
+ $fday -= $day;
+
+ my($hour) = int(24*$fday);
+ $fday -= $hour/24;
+ my($min) = int(24*60*$fday);
+ $fday -= $min/24/60;
+ my($sec) = round(24*3600*$fday);
+ $min++,$sec=0 if ($sec == 60);
+ $hour++,$min=0 if ($min == 60);
+ $day++,$hour=0 if ($hour == 24);
+
+ return sprintf('%02d:%02d:%02d',$hour,$min,$sec);
+ }
+}
+
+sub dayNo(@) # day number, starting at 1
+{
+ my($epoch,$y,$m,$d) =
+ &antsFunUsage(-3,"c..","[epoch,] year, month, day",@_);
+ unless (defined($d)) {
+ $d = $m; $m = $y; $y = $epoch;
+ }
+
+ unless (cardinalp($m)) {
+ $m = lc($m);
+ if ($m =~ /^jan/) { $m = 1; }
+ elsif ($m =~ /^feb/) { $m = 2; }
+ elsif ($m =~ /^mar/) { $m = 3; }
+ elsif ($m =~ /^apr/) { $m = 4; }
+ elsif ($m =~ /^may/) { $m = 5; }
+ elsif ($m =~ /^jun/) { $m = 6; }
+ elsif ($m =~ /^jul/) { $m = 7; }
+ elsif ($m =~ /^aug/) { $m = 8; }
+ elsif ($m =~ /^sep/) { $m = 9; }
+ elsif ($m =~ /^oct/) { $m = 10; }
+ elsif ($m =~ /^nov/) { $m = 11; }
+ elsif ($m =~ /^dec/) { $m = 12; }
+ else { croak("$0: unknown month $m\n"); }
+ }
+
+ my($dn) = 0;
+
+ $epoch += ($epoch < 50) ? 2000 : 1900 # Y2K
+ if ($epoch < 100);
+ $y += ($y < 50) ? 2000 : 1900
+ if ($y < 100);
+
+ croak("$0: &dayNo(): Error: epoch > year\n") # only positive times
+ if ($y < $epoch);
+ while ($epoch < $y) { # entire years
+ $dn += 365 + &leapYearP($epoch);
+ $epoch++;
+ }
+
+ croak("$0: &dayNo(): Error: day > #days of month\n") # current month
+ if ($d > &monthLength($y,$m));
+ $dn += $d;
+ $m--;
+
+ while ($m > 0) { # current year
+ $dn += &monthLength($y,$m);
+ $m--;
+ }
+
+ return $dn
+}
+
+sub frac_day(@) # fractional day
+{
+ my($h,$m,$s);
+ if (@_ == 1) {
+ ($h,$m,$s) = split(':',$_[0]);
+ } else {
+ ($h,$m,$s) = &antsFunUsage(3,'ccf',"<h:m:s>|<hour> <min> <sec>",@_);
+ }
+
+ croak("$0: &frac_day_long(): illegal time spec $h:$m:$s\n")
+ unless (defined($h) && $h>=0 && $h<24 &&
+ defined($m) && $m>=0 && $m<60 &&
+ defined($s) && $s>=0 && $s<60);
+ return $h/24 + $m/24/60 + $s/24/3600;
+}
+
+sub day_secs(@) # seconds since daystart
+{
+ my($h,$m,$s) = &antsFunUsage(3,'ccf',"<hour> <min> <sec>",@_);
+
+ croak("$0: &frac_day_long(): illegal time spec $h:$m:$s\n")
+ unless (defined($h) && $h>=0 && $h<24 &&
+ defined($m) && $m>=0 && $m<60 &&
+ defined($s) && $s>=0 && $s<60);
+ return $h*3600 + $m*60 + $s;
+}
+
+sub str2dec_time(@) # decimal time
+{
+ my($ts,$ds,$epoch) =
+ &antsFunUsage(-1,'.',"'hh:mm[:ss]'[,'[YY]YY/MM/DD'[,epoch]]",@_);
+
+ my($dayNo) = 0;
+ if ($ds ne '') { # date
+ my($yy,$mm,$dd) = split('[-/\.]',$ds);
+ $dayNo = defined($epoch) ?
+ dayNo($epoch,$yy,$mm,$dd) : dayNo($yy,$mm,$dd);
+ }
+
+ my($h,$m,$s) = split(':',$ts);
+ $s = 0 unless defined($s);
+ return $dayNo + &frac_day($h,$m,$s);
+}
+
+sub dec_time(@) # decimal time
+{
+ my($epoch,$yy,$mm,$dd,$h,$m,$s) =
+ &antsFunUsage(7,'ccccccf',"<epoch> <year> <month> <day> <hour> <min> <sec>",@_);
+ return &dayNo($epoch,$yy,$mm,$dd) + &frac_day($h,$m,$s);
+}
+
+sub mmddyy2dec_time(@) # decimal time
+{
+ my($ds,$ts,$epoch) =
+ &antsFunUsage(2,"..","date-string (empty ok), time-string[, epoch]",@_);
+
+ my($time) = 0;
+ if ($ds ne "") { # date
+ my($mm,$dd,$yy) = split('[-/\. ]',$ds);
+ if (defined($epoch)) {
+ $time = dayNo($epoch,$yy,$mm,$dd);
+ } else {
+ $time = dayNo($yy,$yy,$mm,$dd);
+ }
+ }
+
+ my($h,$m,$s) = split(':',$ts); # time
+ croak("$0: &dec_time(): illegal time spec $ts\n")
+ unless (defined($h) && $h>=0 && $h<24 &&
+ defined($m) && $m>=0 && $m<60 &&
+ defined($s) && $s>=0 && $s<60);
+ $time += $h/24 + $m/24/60 + $s/24/3600;
+
+ return $time;
+}
+
+sub ddmmyy2dec_time(@) # decimal time
+{
+ my($epoch,$ds,$ts) =
+ &antsFunUsage(3,"c..","epoch, date-string (empty ok), time-string",@_);
+
+ my($time) = 0;
+ if ($ds ne "") { # date
+ my($dd,$mm,$yy) = split('[-/\.]',$ds);
+ $time = dayNo($epoch,$yy,$mm,$dd);
+ }
+
+ my($h,$m,$s) = split(':',$ts);
+ croak("$0: &dec_time(): illegal time spec $ts\n")
+ unless (defined($h) && $h>=0 && $h<24 &&
+ defined($m) && $m>=0 && $m<60 &&
+ defined($s) && $s>=0 && $s<60);
+ $time += $h/24 + $m/24/60 + $s/24/3600;
+
+ return $time;
+}
+
+sub yymmdd2dec_time(@) # decimal time
+{
+ my($epoch,$ds,$ts) =
+ &antsFunUsage(3,"c..","epoch, date-string (empty ok), time-string (empty ok)",@_);
+
+ my($time) = 0;
+ if ($ds ne "") { # date
+ my($yy,$mm,$dd);
+ if (length($ds) == 6) {
+ $yy = substr($ds,0,2);
+ $mm = substr($ds,2,2);
+ $dd = substr($ds,4,2);
+ } else {
+ ($yy,$mm,$dd) = split('[-/\.]',$ds);
+ }
+ $time = dayNo($epoch,$yy,$mm,$dd);
+ }
+
+ if ($ts ne '') {
+ my($h,$m,$s) = split(':',$ts);
+ croak("$0: &dec_time(): illegal time spec $ts\n")
+ unless (defined($h) && $h>=0 && $h<24 &&
+ defined($m) && $m>=0 && $m<60 &&
+ defined($s) && $s>=0 && $s<60);
+ $time += $h/24 + $m/24/60 + $s/24/3600;
+ }
+
+ return $time;
+}
+
+sub date2str(@)
+{
+ my($MM,$DD,$YYYY) = &antsFunUsage(3,"ccc","month, day, year",@_);
+ $YYYY += 2000 if ($YYYY < 50);
+ $YYYY += 1900 if ($YYYY < 100);
+ return sprintf("%02d",$MM) . "/" .
+ sprintf("%02d",$DD) . "/" . $YYYY;
+}
+
+sub card_date2str(@)
+{
+ my($DDMMYY) = &antsFunUsage(1,"c","ddmmyy",@_);
+ $DDMMYY = sprintf("%06d",$DDMMYY);
+ return &fmtdate(substr($DDMMYY,2,2),substr($DDMMYY,0,2),substr($DDMMYY,4,2));
+}
+
+sub time2str(@)
+{
+ my($HH,$MM) = &antsFunUsage(2,"cc","hr, min",@_);
+ return sprintf("%02d",$HH) . ":" . sprintf("%02d",$MM);
+}
+
+sub card_time2str(@)
+{
+ my($HHMM) = &antsFunUsage(1,"c","hrmin",@_);
+ return &fmttime(int($HHMM/100),$HHMM%100);
+}
+
+#----------------------------------------------------------------------
+# Lat/Lon Conversion
+#----------------------------------------------------------------------
+
+sub wraplon(@) # get sign of longitudes right
+{
+ my($deg) = &antsFunUsage(1,'f','deg',@_);
+ return ($deg > 180) ? $deg - 360 : $deg;
+}
+
+sub dmh2deg(@) # dd mm.m NSEW -> dd.d
+{
+ my($deg,$min,$hemisph) =
+ &antsFunUsage(3,"ff1","deg, min, hemisphere",@_);
+ croak("$0 dmh2d(): <deg> may not be -ve\n") if ($deg < 0);
+ croak("$0 dmh2d(): <min> may not be -ve\n") if ($min < 0);
+ $deg += $min/60;
+ $_ = $hemisph;
+ SWITCH: {
+ $deg = -$deg, last SWITCH if (/[sSwW]/);
+ last SWITCH if (/[nNeE]/);
+ croak("$0 dmh2d(): $hemisph is an invalid hemisphere id\n");
+ }
+ return $deg;
+}
+
+sub dmsh2deg(@) # dd mm ss NSEW -> dd.d
+{
+ my($deg,$min,$sec,$hemisph) =
+ &antsFunUsage(4,"fff1","deg, min, sec, hemisphere",@_);
+ croak("$0 dmsh2d(): <deg> may not be -ve\n") if ($deg < 0);
+ croak("$0 dmsh2d(): <min> may not be -ve\n") if ($min < 0);
+ croak("$0 dmsh2d(): <sec> may not be -ve\n") if ($sec < 0);
+ $deg += $min/60 + $sec/3600;
+ $_ = $hemisph;
+ SWITCH: {
+ $deg = -$deg, last SWITCH if (/[sSwW]/);
+ last SWITCH if (/[nNeE]/);
+ croak("$0 dmh2d(): $hemisph is an invalid hemisphere id\n");
+ }
+ return $deg;
+}
+
+sub str2deg(@) # string containing dd [mm.m] [NSEW] -> dd.d
+{
+ my($s) = &antsFunUsage(1,".","'deg[ :][min][ ]hemisphere'",@_);
+ my($deg,$a,$b) = ($s =~ m{^([-\d]+)[\s:]([\d\.]+)\s*([NSEW])$});
+# print(STDERR "--> $deg, $a, $b\n");
+ return ($b eq "") ? &dmh2d($deg,0,$a) : &dmh2d($deg,$a,$b);
+}
+
+sub GMT2deg(@) # GMT degree format to decimal
+{
+ my($GMT) = &antsFunUsage(1,".","GMT-degs ",@_);
+ return (substr($1,0,1) eq "-") ? $1-$2/60.0 : $1+$2/60.0
+ if ($GMT =~ /\s*([^:]+):([^:]+)/);
+ return $GMT;
+}
+
+#----------------------------------------------------------------------
+# Temp-Scale Conversion
+#----------------------------------------------------------------------
+
+{ my($ITS);
+
+sub ITS_68(@) # T90|T68 -> T68
+{
+ unless (defined($ITS)) {
+ $ITS = &antsRequireParam('ITS');
+ croak("$0 ITS_68(): ITS == $ITS???\n")
+ unless ($ITS == 68 || $ITS ==90);
+ unless ($ITS == 68) {
+ croak("$0 ITS_68(): can't change %ITS after flushing header\n")
+ if ($antsHeadersPrinted);
+ &antsAddParams('ITS',68);
+ }
+ }
+ my($temp) = &antsFunUsage(1,".","temp",@_);
+ return nan unless (numberp($temp));
+ return($temp) if ($ITS == 68);
+ return $temp * 1.00024;
+}
+
+} # static scope
+
+{ my($ITS);
+
+sub ITS_90(@) # T90|T68 -> T90
+{
+ unless (defined($ITS)) {
+ $ITS = &antsRequireParam('ITS');
+ croak("$0 ITS_90(): ITS == $ITS???\n")
+ unless ($ITS == 68 || $ITS ==90);
+ unless ($ITS == 90) {
+ croak("$0 ITS_90(): can't change %ITS after flushing header\n")
+ if ($antsHeadersPrinted);
+ &antsAddParams('ITS',90);
+ }
+ }
+ my($temp) = &antsFunUsage(1,".","temp",@_);
+ return nan unless (numberp($temp));
+ return($temp) if ($ITS == 90);
+ return $temp / 1.00024;
+}
+
+}
+
+#----------------------------------------------------------------------
+# Oxygen Unit Conversion
+#
+# - old units (e.g. sd2) are ml/l
+# - new units (e.g. WOCE) are umol/kg => independent of pressure!
+# - conversion (from [http://sea-mat.whoi.edu/robbins/ox_units.m]; Paul
+# Robbins) uses potential density ref'd to surface --- makes sense
+# because titration is presumably done at atmospheric pressure
+# - constant divisor is volume of one mole derived from gas law
+# (PV = nRT) in the right units (whatever)
+#----------------------------------------------------------------------
+
+{ my(@fc);
+ sub O2mlpl2umpkg(@)
+ {
+ return nan if isnan($_[3]);
+ my($S,$T,$P,$mlpl) =
+ &antsFunUsage(4,'ffff','[S, T, P [dbar], O2 [ml/l]]',
+ \@fc,'salin','temp','press','O2',@_);
+ return $mlpl * 1000/(1000+sigma($S,$T,$P,0)) / .022403;
+ }
+}
+
+{ my(@fc);
+ sub O2umpkg2mlpl(@)
+ {
+ return nan if isnan($_[3]);
+ my($S,$T,$P,$umpkg) =
+ &antsFunUsage(4,'ffff','[S, T, P [dbar], O2 [ml/l]]',
+ \@fc,'salin','temp','press','O2',@_);
+ return .022403 * $umpkg * (1000+sigma($S,$T,$P,0))/1000;
+ }
+}
+
+#----------------------------------------------------------------------
+# Color Conversion
+#
+# - algorithms taken from the web; source given alternatively as ACM
+# and Foley and VanDam
+# - from the available GMT default cpt files, it looks like
+# the range for hue is 0 - 359 (angles on a circle)
+# - ACM implementation uses a hue range of 0-6 with pure red being 0 or 6
+# - ACM implementation uses range of 0-1 for R,G,B
+# - in HSV, gray scales are not uniquely defined; I extended the
+# algorithms to behave like matlab in this case, i.e. return a hue of
+# pure red (0)
+#----------------------------------------------------------------------
+
+sub HSV2RGB(@)
+{
+ my($H,$S,$V) = &antsFunUsage(3,"fff","H (0-360), S (0-1), V (0-1), ",@_);
+ my($m,$n,$f,$i);
+
+ $H = 0 if ($H < 0 && $H >= -$PRACTICALLY_ZERO);
+ croak("$0 HSV2RGB(): H=$H out of range\n") if ($H < 0 || $H > 360);
+ croak("$0 HSV2RGB(): S=$S out of range\n") if ($S < 0 || $S > 1);
+ croak("$0 HSV2RGB(): V=$V out of range\n") if ($V < 0 || $V > 1);
+
+ $i = POSIX::floor($H/60); # ACM implementation uses [0-6] with red = 0 = 6
+ $f = $H/60 - $i;
+ $f = 1 - $f if (!($i & 1)); # if i is even
+ $m = $V * (1 - $S);
+ $n = $V * (1 - $S * $f);
+ return (int(255*$V+0.5),int(255*$n+0.5),int(255*$m+0.5)) if ($i==0 || $i==6);
+ return (int(255*$n+0.5),int(255*$V+0.5),int(255*$m+0.5)) if ($i == 1);
+ return (int(255*$m+0.5),int(255*$V+0.5),int(255*$n+0.5)) if ($i == 2);
+ return (int(255*$m+0.5),int(255*$n+0.5),int(255*$V+0.5)) if ($i == 3);
+ return (int(255*$n+0.5),int(255*$m+0.5),int(255*$V+0.5)) if ($i == 4);
+ return (int(255*$V+0.5),int(255*$m+0.5),int(255*$n+0.5)) if ($i == 5);
+ croak("$0 HSV2RGB(): implementation error");
+}
+
+sub RGB2HSV(@)
+{
+ my($R,$G,$B) = &antsFunUsage(3,"cc","R, G, B",@_);
+ my($V,$x,$f,$i,$H);
+
+ $R /= 255; $G /= 255; $B /= 255;
+ croak("$0 RGB2HSV(): R out of range\n") if ($R < 0 || $R > 1);
+ croak("$0 RGB2HSV(): G out of range\n") if ($G < 0 || $G > 1);
+ croak("$0 RGB2HSV(): B out of range\n") if ($B < 0 || $B > 1);
+
+ $x = min($R,$G,$B);
+ $V = max($R,$G,$B);
+ return (0,0,$V) if ($V == $x); # any hue is valid
+
+ $f = ($R == $x) ? $G - $B : (($G == $x) ? $B - $R : $R - $G);
+ $i = ($R == $x) ? 3 : (($G == $x) ? 5 : 1);
+
+ $H = 60 * ($i - $f / ($V - $x));
+ $H = 0 if ($H == 360);
+
+ return ($H, ($V - $x)/$V, $V);
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/libfuns.pl
@@ -0,0 +1,280 @@
+#======================================================================
+# L I B F U N S . P L
+# doc: Wed Mar 24 11:49:13 1999
+# dlm: Fri Apr 16 15:58:47 2010
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 269 45 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Mar 24, 1999: - copied from the c-version of NR
+# Mar 26, 1999: - added stuff for better [./fit]
+# Sep 18, 1999: - argument typechecking
+# Oct 04, 1999: - added gauss(), normal()
+# Jan 25, 2001: - added f(), sgn()
+# Apr 16, 2010: - added sinc()
+
+require "$ANTS/libvec.pl"; # rad()
+
+#----------------------------------------------------------------------
+
+sub gauss(@)
+{
+ my($x,$peak,$mean,$efs) = &antsFunUsage(4,"ffff","x, peak, mean, e-folding scale",@_);
+ return $peak * exp( -(($x-$mean) / $efs)**2);
+}
+
+sub normal(@)
+{
+ my($x,$area,$mean,$sigma) = &antsFunUsage(4,"ffff","x, area, mean, stddev",@_);
+ my($pi) = 3.14159265358979;
+ return $area/(sqrt(2*$pi)*$sigma) * exp(-((($x-$mean) / $sigma)**2)/2);
+}
+
+#----------------------------------------------------------------------
+# &f(lat) calculate coriolis param
+#----------------------------------------------------------------------
+
+sub f(@)
+{
+ my($lat) = &antsFunUsage(1,"f","lat",@_);
+ my($Omega) = 7.292e-5; # Gill (1982)
+
+ return 2 * $Omega * sin(rad($lat));
+}
+
+#----------------------------------------------------------------------
+# &sgn(v) return -1/0/+1
+#----------------------------------------------------------------------
+
+sub sgn(@)
+{
+ my($val) = &antsFunUsage(1,"f","val",@_);
+ return 0 if ($val == 0);
+ return ($val < 0) ? -1 : 1;
+}
+
+#======================================================================
+
+# rest of library cooked up from the diverse special function routines of NR
+# Chapter 6. No attempt to clean up the code has been made.
+
+#----------------------------------------------------------------------
+# 6.1 Gamma Function et al
+#----------------------------------------------------------------------
+
+sub gammln(@)
+{
+ my($xx) = &antsFunUsage(1,"f","xx",@_);
+ my($x,$y,$tmp,$ser);
+ my(@cof) = (76.18009172947146, -86.50532032941677,
+ 24.01409824083091, -1.231739572450155,
+ 0.1208650973866179e-2, -0.5395239384953e-5);
+ my($j);
+
+ $x = $xx;
+ $y = $x;
+ $tmp = $x + 5.5;
+ $tmp -= ($x+0.5) * log($tmp);
+ $ser = 1.000000000190015;
+ for ($j=0; $j<=5; $j++) {
+ $ser += $cof[$j] / ++$y;
+ }
+ return -$tmp + log(2.5066282746310005*$ser/$x);
+}
+
+#----------------------------------------------------------------------
+# 6.2. Incomplete Gamma Function, Error Function et al
+#----------------------------------------------------------------------
+
+{ my($ITMAX)=100; my($EPS)=3.0e-7; # static vars
+
+sub gser(@)
+{
+ my($a,$x,$glnR) = &antsFunUsage(-2,"ff","a,x[,ref to gln]",@_);
+ my($gln);
+ my($n);
+ my($sum,$del,$ap);
+
+ $gln = &gammln($a);
+ $$glnR = $gln if (defined($glnR));
+
+ return 0 if ($x == 0);
+ croak("$0 (libspecfuns.pl): x<0 ($x) in &gser()\n")
+ if ($x < 0);
+
+ $ap = $a;
+ $sum = 1 / $a;
+ $del = $sum;
+ for ($n=1; $n<=$ITMAX; $n++) {
+ ++$ap;
+ $del *= $x/$ap;
+ $sum += $del;
+ return $sum * exp(-$x+$a*log($x)-$gln)
+ if (abs($del) < abs($sum)*$EPS);
+ }
+ croak("$0 (libspecfuns.pl): a ($a) too large, " .
+ "ITMAX ($ITMAX) too small in &gser()\n");
+}
+
+} # end of static scope
+
+{ my($ITMAX)=100; my($EPS)=3.0e-7; my($FPMIN)=1.0e-30; # static
+
+sub gcf(@)
+{
+ my($a,$x,$glnR) = &antsFunUsage(-2,"ff","a,x[,ref to gln]",@_);
+ my($gln);
+ my($i);
+ my($an,$b,$c,$d,$del,$h);
+
+ $gln = &gammln($a);
+ $$glnR = $gln if (defined($glnR));
+
+ $b = $x + 1 - $a;
+ croak("$0 (libspecfuns.pl): illegal params (a = x + 1) in &gcf()\n")
+ unless ($b);
+ $c = 1 / $FPMIN;
+ $d = 1 / $b;
+ $h = $d;
+ for ($i=1; $i<=$ITMAX; $i++) {
+ $an = -$i * ($i - $a);
+ $b += 2.0;
+ $d = $an * $d + $b;
+ $d = $FPMIN if (abs($d) < $FPMIN);
+ $c = $b + $an/$c;
+ $c = $FPMIN if (abs($c) < $FPMIN);
+ $d = 1 / $d;
+ $del= $d * $c;
+ $h *= $del;
+ last if (abs($del-1) < $EPS);
+ }
+ croak("$0 (libspecfuns.pl): a ($a) too large," .
+ " ITMAX ($ITMAX) too small in &gcf()\n")
+ if ($i > $ITMAX);
+ return exp(-$x + $a*log($x) - $gln) * $h;
+}
+
+} # end of static scope
+
+sub gammq(@)
+{
+ my($a,$x) = &antsFunUsage(2,"ff","a,x",@_);
+ croak("$0 (libspecfuns.pl): Invalid arguments in &gammq()\n")
+ if ($x < 0 || $a <= 0);
+ return ($x < ($a+1)) ?
+ 1 - &gser($a,$x) :
+ &gcf($a,$x);
+}
+
+#----------------------------------------------------------------------
+
+sub erfcc(@)
+{
+ my($x) = &antsFunUsage(1,"f","x",@_);
+ my($t,$z,$ans);
+
+ $z = abs($x);
+ $t = 1/(1+0.5*$z);
+ $ans = $t*exp(-$z*$z-1.26551223+$t*(1.00002368+$t*(0.37409196+$t*(0.09678418+
+ $t*(-0.18628806+$t*(0.27886807+$t*(-1.13520398+$t*(1.48851587+
+ $t*(-0.82215223+$t*0.17087277)))))))));
+ return $x >= 0 ? $ans : 2.0-$ans;
+}
+
+{ my($warned) = 0; # static
+
+sub erf(@)
+{
+ my($x) = &antsFunUsage(1,"f","x",@_);
+ &antsInfo("(libspecfuns.pl) WARNING: using approximate erf()"),$warned=1
+ unless ($warned);
+ return 1-&erfcc($x);
+}
+
+}
+
+#----------------------------------------------------------------------
+# 6.3. Incomplete Beta Function et al
+#----------------------------------------------------------------------
+
+sub betai(@)
+{
+ my($a,$b,$x) = &antsFunUsage(3,"fff","a,b,x",@_);
+ my($bt);
+
+ croak("$0 (liberrf.pl): x (=$x) out of range in betai()\n")
+ if ($x < 0 || $x > 1);
+ if ($x == 0 || $x == 1) {
+ $bt = 0;
+ } else {
+ $bt = exp(gammln($a+$b)-gammln($a)-gammln($b)+$a*log($x)+$b*log(1-$x));
+ }
+ if ($x < ($a+1)/($a+$b+2)) {
+ return $bt * betacf($a,$b,$x) / $a;
+ } else {
+ return 1 - $bt*betacf($b,$a,1-$x) / $b;
+ }
+}
+
+#----------------------------------------------------------------------
+
+{ # static scope
+
+ my($MAXIT) = 100;
+ my($EPS) = 3.0e-7;
+ my($FPMIN) = 1.0e-30;
+
+sub betacf(@)
+{
+ my($a,$b,$x) = &antsFunUsage(3,"fff","a,b,x",@_);
+ my($m,$m2);
+ my($aa,$c,$d,$del,$h,$qab,$qam,$qap);
+
+ $qab = $a + $b;
+ $qap = $a + 1;
+ $qam = $a - 1;
+ $c = 1;
+ $d = 1 - $qab*$x/$qap;
+ $d = $FPMIN if (abs($d) < $FPMIN);
+ $d = 1 / $d;
+ $h = $d;
+ for ($m=1; $m<=$MAXIT; $m++) {
+ $m2 = 2 * $m;
+ $aa = $m*($b-$m)*$x / (($qam+$m2)*($a+$m2));
+ $d = 1 + $aa*$d;
+ $d = $FPMIN if (abs($d) < $FPMIN);
+ $c = 1 + $aa/$c;
+ $c = $FPMIN if (abs($c) < $FPMIN);
+ $d = 1 / $d;
+ $h *= $d * $c;
+ $aa = -($a+$m)*($qab+$m)*$x / (($a+$m2)*($qap+$m2));
+ $d = 1 + $aa*$d;
+ $d = $FPMIN if (abs($d) < $FPMIN);
+ $c = 1 + $aa/$c;
+ $c = $FPMIN if (abs($c) < $FPMIN);
+ $d = 1 / $d;
+ $del= $d * $c;
+ $h *= $del;
+ last if (abs($del-1) < $EPS);
+ }
+ croak("$0 (liberrf.pl): a or b too big, or MAXIT too small in betacf")
+ if ($m > $MAXIT);
+ return $h;
+}
+
+} # end of static scope
+
+#----------------------------------------------------------------------
+# normalized cardinal sine as used, e.g., in JAOT/polzin02
+#----------------------------------------------------------------------
+
+sub sinc($)
+{
+ my($piX) = 3.14159265358979 * $_[0];
+ return $piX==0 ? 1 : sin($piX)/$piX;
+}
+
+#----------------------------------------------------------------------
+
+1;
new file mode 100644
--- /dev/null
+++ b/libgamma.pl
@@ -0,0 +1,42 @@
+#======================================================================
+# L I B G A M M A . P L
+# doc: Mon Mar 8 11:46:36 1999
+# dlm: Tue Jan 2 11:27:11 2001
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 17 40 NIL 0 0 72 0 2 4 ofnI
+#======================================================================
+
+# HISTORY:
+# Sep 25, 2000: - finished implementation
+# Jan 02, 2001: - updated documentation (here)
+
+# NOTES:
+# - gamma library stub to allow -L option
+# - requires the perl interface of the (fortran library) gamma.a
+# [/usr/local/src/gamma/perl-interface]
+# - main use of this library: [gamma_n]
+
+# SYNOPSIS:
+# $gamma::temp_scale = &antsRequireParam(temp_scale);
+# MUST DO THIS 1ST
+# &gamma::gamma_n(S,T,P,lon,lat[,dg_lo,dg_hi])
+# [$|@]S salinity
+# [$|@]T temperature (scale in $gamma::temp_scale)
+# [$|@]P pressure
+# $lat latitude
+# $lon longitude
+# [$|\$|\@]dg_lo low end of error range
+# [$|\$|\@]dg_lo high end of error range
+# &gamma::gamma_n_lol(buf,S_f,T_f,P_f,gam_f,lon,lat[,dg_lo_f,dg_hi_f])
+# @buf LoL containing columns for S,T,P,gamma[,dg_lo,dg_hi]
+# $S_f salinity field
+# $T_f temperature field
+# $P_f pressure field
+# $lat latitude
+# $lon longitude
+# $dg_lo_f low end of error range (field number)
+# $dg_lo_f high end of error range (field number)
+
+use gamma;
+
+1;
new file mode 100644
--- /dev/null
+++ b/libstats.pl
@@ -0,0 +1,308 @@
+#======================================================================
+# L I B S T A T S . P L
+# doc: Wed Mar 24 13:59:27 1999
+# dlm: Thu Apr 26 09:49:47 2012
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 33 64 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Mar 24, 1999: - created for the ANO paper
+# Mar 27, 1999: - extended
+# Sep 18, 1999: - argument typechecking
+# Sep 30, 1999: - added gauss()
+# Oct 04, 1999: - moved gauss() to [./libfuns.pl] (changed from specfuns)
+# Oct 20, 1999: - changed, 'cause I understand it better
+# Oct 21, 1999: - changed &Fishers_z to &r2z(); added &z2r()
+# - added &sig_rr(), &sig_rrtrue
+# Jan 22, 2002: - added N(), avg(), stddev(), min(), max()
+# Feb 27, 2006: - adjusted median() for compat with NR (even # of points)
+# - added medianF()
+# Jun 27, 2006: - added medianFNaN()
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+# - made median respect nan based on perlfunc(1)
+# Apr 25, 2008: - added &bootstrap()
+# Oct 24, 2010: - replaced grep { $_ == $_ } by grep { numberp($_) } everywhere
+# - added &fixLowSampStat()
+# Nov 5, 2010: - added std (stderr would have been better but that's used in libPOSIX.pl
+# Dec 18, 2010: - added stddev2, mad, mad2
+# Dec 31, 2010: - added rms()
+# Jul 2, 2011: - added mad2F()
+# Mar 10, 2012: - medianF() -> medianAnts_(); mad2F() -> mad2Ants_()
+# - added sum()
+# Apr 26, 2012: - BUG: std() did not allow nan as stddev input
+
+require "$ANTS/libfuns.pl";
+
+#----------------------------------------------------------------------
+# estimate stderr given stddev & degrees of freedom
+# - return nan for dof <= 0
+#----------------------------------------------------------------------
+
+sub std(@)
+{
+ my($sig,$dof) =
+ &antsFunUsage(2,".c","stddev, deg_of_freedom",@_);
+ return nan unless ($dof > 0);
+ return $sig / sqrt($dof);
+}
+
+#----------------------------------------------------------------------
+# calc standard stats from vector of vals
+#----------------------------------------------------------------------
+
+sub min(@)
+{
+ my($min) = 9e99;
+ for (my($i)=0; $i<=$#_; $i++) {
+ $min = $_[$i] if (numberp($_[$i]) && $_[$i] < $min);
+ }
+ return $min<9e99 ? $min : nan;
+}
+
+sub max(@)
+{
+ my($max) = -9e99;
+ for (my($i)=0; $i<=$#_; $i++) {
+ $max = $_[$i] if (numberp($_[$i]) && $_[$i] > $max);
+ }
+ return $max>-9e99 ? $max : nan;
+}
+
+sub N(@)
+{
+ my($N) = 0;
+ for (my($i)=0; $i<=$#_; $i++) { $N++ if (numberp($_[$i])); }
+ return $N;
+}
+
+sub sum(@)
+{
+ my($N) = my($sum) = 0;
+ for (my($i)=0; $i<=$#_; $i++) { $N++,$sum+=$_[$i] if (numberp($_[$i])); }
+ return ($N>0)?$sum:nan;
+}
+
+sub avg(@)
+{
+ my($N) = my($sum) = 0;
+ for (my($i)=0; $i<=$#_; $i++) { $N++,$sum+=$_[$i] if (numberp($_[$i])); }
+ return ($N>0)?$sum/$N:nan;
+}
+
+sub stddev2(@) # avg, val, val, val, ...
+{
+ my($N) = my($sum) = 0;
+ for (my($i)=1; $i<=$#_; $i++) {
+ $N++,$sum+=($_[0]-$_[$i])**2 if (numberp($_[$i]));
+ }
+ return ($N>1)?sqrt($sum/($N-1)):nan;
+}
+
+sub stddev(@)
+{
+ my($avg) = &avg(@_);
+ return numberp($avg) ? stddev2($avg,@_) : nan;
+}
+
+sub rms(@)
+{
+ my($N) = my($sum) = 0;
+ for (my($i)=0; $i<=$#_; $i++) { $N++,$sum+=$_[$i]**2 if (numberp($_[$i])); }
+ return ($N>0)?sqrt($sum/$N):nan;
+}
+
+sub median(@)
+{
+ my(@svals) = sort {$a <=> $b} grep { numberp($_) } @_;
+ return nan if (@svals == 0);
+ return (@svals & 1) ?
+ $svals[$#svals/2] :
+ 0.5 * ($svals[$#svals/2] + $svals[$#svals/2+1]);
+}
+
+sub medianAnts_($)
+{
+ my($fnr) = @_;
+ my(@svals) = sort {@{$a}[$fnr] <=> @{$b}[$fnr]} grep { numberp(@{$_}[$fnr]) } @ants_;
+ return nan if (@svals == 0);
+ return (@svals & 1) ?
+ $svals[$#svals/2][$fnr] :
+ 0.5 * ($svals[$#svals/2][$fnr] + $svals[$#svals/2+1][$fnr]);
+}
+
+sub mad2(@) # avg, val, val, val, ...
+{
+ my($N) = my($sum) = 0;
+ for (my($i)=1; $i<=$#_; $i++) {
+ $N++,$sum+=abs($_[0]-$_[$i]) if (numberp($_[$i]));
+ }
+ return ($N>0)?sqrt($sum/$N):nan;
+}
+
+sub mad(@)
+{
+ my($median) = &median(@_);
+ return numberp($median) ? mad2($median,@_) : nan;
+}
+
+sub mad2Ants_($$)
+{
+ my($median,$fnr) = @_;
+ my($sum,$n);
+
+ for (my($r)=0; $r<@ants_; $r++) {
+ next unless numberp($ants_[$r][$fnr]);
+ $sum += abs($median - $ants_[$r][$fnr]);
+ $n++
+ }
+ return ($n>0) ? $sum/$n : nan;
+}
+
+#----------------------------------------------------------------------
+# &bootstrap(nDraw,cLim,statFun,val[,...])
+# nDraw number of synthetic samples to draw
+# cLim confidence limit (e.g. 0.95)
+# statFun pointer to stats function
+# val[,...] data values
+#
+# e.g. bootstrap(1000,.5,\&avg,1,2,1000)
+#----------------------------------------------------------------------
+
+sub bootstrap($$$@)
+{
+ my($nDraw,$cLim,$statFun,@vals) = @_;
+ my(@sv,@stats);
+
+ for (my($s)=0; $s<$nDraw; $s++) {
+ for (my($i)=0; $i<@vals; $i++) {
+ $sv[$i] = $vals[int(rand(@vals))];
+ }
+ $stats[$s] = &$statFun(@sv);
+ }
+ @stats = sort {$a <=> $b} grep { numberp($_) } @stats;
+ my($cli) = int($nDraw*(1-$cLim)/2);
+ return ($stats[$cli],$stats[$#stats-$cli]);
+}
+
+#----------------------------------------------------------------------
+# &fixLowSampStat(statRef,nsamp[])
+# - replace stat (variance, stddev, stderr) based on small (<10) samples
+# with median calculated from all stats
+# - median of all stats is chosen to allow routine to work even if all
+# stats are based on small samples
+#----------------------------------------------------------------------
+
+sub fixLowSampStat($@)
+{
+ my($statR,@nsamp) = @_;
+
+ my($medStat) = median(@{$statR});
+ for (my($i)=0; $i<@{$statR}; $i++) {
+ $statR->[$i] = $medStat
+ unless ($nsamp[$i]>=10 || !defined($statR->[$i]) || $statR->[$i]>$medStat);
+ }
+}
+
+#----------------------------------------------------------------------
+# significance of difference of means (NR, 2nd ed, 14.2)
+#----------------------------------------------------------------------
+
+sub Students_t(@)
+{
+ my($mu1,$sig1,$N1,$mu2,$sig2,$N2) =
+ &antsFunUsage(6,"ffcffc","mu1, sigma1, N1, mu2, sigma2, N2",@_);
+ my($var1) = $sig1 * $sig1;
+ my($var2) = $sig2 * $sig2;
+ my($sd) = sqrt($var1 + $var2 / ($N1+$N2-2) * (1/$N1 + 1/$N2));
+ return ($mu1-$mu2) / $sd;
+}
+
+sub slevel_mudiff1(@)
+{
+ my($mu1,$sig1,$N1,$mu2,$sig2,$N2) =
+ &antsFunUsage(6,"ffcffc","mean1, sqrt(var1), N1, mean2, sqrt(var2), N2",@_);
+ my($df) = $N1 + $N2 - 2;
+ return &betai(0.5*$df,0.5,
+ $df/($df + &Students_t(mu1,$sig1,$N1,$mu2,$sig2,$N2)**2));
+}
+
+#----------------------------------------------------------------------
+# significance of correlation coefficient (NR, 2nd ed, 14.5)
+#----------------------------------------------------------------------
+
+sub slevel_r(@)
+{
+ my($r,$N) = &antsFunUsage(2,"fc","r, N",@_);
+ return &erfcc(abs($r) * sqrt($N/2));
+}
+
+#----------------------------------------------------------------------
+# significance of difference btw two measured correlation coeffs
+# using Fisher's z (from NR, 2nd ed, 14.5). NB: averaging correlation
+# coefficients is done using [avgr]
+# NB: significance level is only good if correlated variables form
+# a binormal distribution
+#----------------------------------------------------------------------
+
+sub r2z(@)
+{
+ my($r) = &antsFunUsage(1,"f","<r>",@_);
+ return 0.5 * log((1+$r)/(1-$r));
+}
+
+sub z2r(@)
+{
+ my($z) = &antsFunUsage(1,"f","<z>",@_);
+ my($e) = exp(2*$z);
+ return ($e-1) / ($e+1);
+}
+
+sub slevel_rrtrue(@)
+{
+ my($r,$N,$rtrue) = &antsFunUsage(3,"fcf","r, N, r_true",@_);
+ croak("$0 (libstats.pl): N (=$N) < 10 in &slevel_rrtrue()\n")
+ if ($N < 10);
+ return &erfcc(abs(&r2z($r) - (&r2z($rtrue) + $rtrue/(2*$N-2))) *
+ sqrt($N - 3) / sqrt(2));
+}
+
+sub slevel_zz(@)
+{
+ my($z1,$N1,$z2,$N2) = &antsFunUsage(4,"fcfc","z1, N1, z2, N2",@_);
+ croak("$0 (libstats.pl): N (=$N1,$N2) < 10 in &slevel_zz()\n")
+ if ($N1 < 10 || $N2 < 10);
+ return &erfcc(abs($z1-$z2) / sqrt(2/($N1-3) + 2/($N2-3)));
+}
+
+sub slevel_rr(@)
+{
+ my($r1,$N1,$r2,$N2) = &antsFunUsage(4,"fcfc","r1, N1, r2, N2",@_);
+ return &slevel_zz(&r2z($r1),$N1,&r2z($r2),$N2);
+}
+
+#----------------------------------------------------------------------
+# significance of difference btw two measured correlation coeffs
+# from brookes+dick63, p.216f
+# NB: result is returned as ratio of difference in Fisher's z to
+# standard error of Fisher's z; values >> 1 indicate that difference
+# is significant
+#----------------------------------------------------------------------
+
+sub sig_rrtrue(@)
+{
+ my($r,$N,$rtrue) = &antsFunUsage(3,"fcf","r, N, r_true",@_);
+ return abs(&r2z($r) - &r2z($rtrue)) * sqrt($N-3);
+
+}
+
+sub sig_rr(@)
+{
+ my($r1,$N1,$r2,$N2) = &antsFunUsage(4,"fcfc","r1, N1, r2, N2",@_);
+ return abs(&r2z($r1) - &r2z($r2)) / (1/sqrt($N1-3)+1/sqrt($N2-3));
+}
+
+#----------------------------------------------------------------------
+
+1;
+
new file mode 100644
--- /dev/null
+++ b/libtides.pl
@@ -0,0 +1,44 @@
+#======================================================================
+# L I B T I D E S . P L
+# doc: Thu Aug 24 21:37:14 2006
+# dlm: Thu Apr 26 10:22:53 2012
+# (c) 2006 A.M. Thurnherr
+# uE-Info: 17 0 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# tidal calculations
+
+# HISTORY:
+# Aug 24, 2006: - created during GRAVILUCK
+# Jan 22, 2008: - renamed M2() to M2_bias()
+# - added M2_phase()
+# Apr 26, 2012: - added K1 & M2 tidal frequencies
+
+#----------------------------------------------------------------------
+# tidal frequencies
+# - taken from thesis Makefile
+# - according to my memory, the values are from Apel's book
+#----------------------------------------------------------------------
+
+$M2 = 24/1.9322;
+$K1 = 24/1.0027;
+
+#----------------------------------------------------------------------
+# given t0, a decimal day at the beginning of "flood", return a scale
+# between -1 and 1 that can be multiplied with the max tidal flow amplitude
+# to estimate tidal velocity at time t.
+#----------------------------------------------------------------------
+
+sub M2_bias(@)
+{
+ my($t0,$t) = &antsFunUsage(2,'ff','time-origin, time',@_);
+ return sin(2*3.14159265358979 * ($t-$t0) / ($M2/24));
+}
+
+sub M2_phase(@)
+{
+ my($t0,$t) = &antsFunUsage(2,'ff','time-origin, time',@_);
+ return round(360 * frac(($t-$t0) / ($M2/24)));
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/libubtest.pl
@@ -0,0 +1,30 @@
+#======================================================================
+# L I B U B T E S T . P L
+# doc: Sun Mar 21 09:35:05 1999
+# dlm: Mon Jul 24 15:10:05 2006
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 10 32 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# overloaded equal() routine for ubtest
+# NB: tests relative errors!!!
+
+# HISTORY:
+# Mar 21, 1999: - created
+# Sep 18, 1999: - argument typechecking
+
+$error = 1e-6;
+
+sub equal($$)
+{
+ my($target,$val) = &antsFunUsage(2,"ff","target, val",@_);
+ my($abserr) = $target-$val;
+ my($relerr) = abs($abserr / ($target ? $target : 1));
+ if ($relerr > $error) {
+ print(STDERR "Equality failure --- abs err = $abserr, rel err = $relerr\n");
+ exit(1);
+ }
+ exit(0);
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/libvec.pl
@@ -0,0 +1,300 @@
+#======================================================================
+# L I B V E C . P L
+# doc: Sat Mar 20 12:50:32 1999
+# dlm: Thu Apr 22 11:32:54 2010
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 147 34 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Mar 20, 1999: - created for ANTS_2.1 (no more c-code)
+# May 27, 1999: - added polar/cartesian conversions
+# Sep 18, 1999: - argument typechecking
+# Dec 10, 1999: - vel_u(), vel_v(), vel_dir(), vel_mag()
+# Mar 07, 2000: - proj(), deg(), rad()
+# Apr 18, 2002: - area()
+# Jan 6, 2003: - changed dist() output to meters
+# Jan 16, 2003: - renamed vel_vel() to vel_speed()
+# Sep 3, 2003: - dir_bias()
+# May 13, 2004: - BUG: had fogotten to adapt area() to new dist()
+# May 21, 2004: - forced zero distance on &dist() if lat/lon does
+# not change (avoid roundoff error)
+# Jun 22, 2004: - added GMTdeg(), dir()
+# Nov 11, 2004: - BUG: roundoff test in dist() was done before
+# conversion to numbers
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+# Jul 24, 2006: - modified to use equal()
+# Nov 16, 2006: - added degmin()
+# Dec 19, 2007: - addapted vel_speed(), vel_dir() to new &antsFunUsage()
+# - same routines now return nan on nan input
+# Jan 15, 2007: - BUG: vel_dir() was broken
+# Jun 14, 2009: - added p_vel()
+# Nov 5, 2009: - added angle(); vel_bias() => angle_diff()
+# Apr 22, 2010: - added angle_ts()
+
+require "$ANTS/libPOSIX.pl"; # acos()
+
+#----------------------------------------------------------------------
+# &rad() calc radians
+# °() calc degrees
+#----------------------------------------------------------------------
+
+$PI = 3.14159265358979;
+
+sub rad(@)
+{
+ my($d) = &antsFunUsage(1,"f","<deg>",@_);
+ return $d/180 * $PI;
+}
+
+sub deg(@)
+{
+ my($r) = &antsFunUsage(1,"f","<rad>",@_);
+ return $r/$PI * 180;
+}
+
+
+#----------------------------------------------------------------------
+# &proj(from_x,from_y,onto_unit_x,onto_unit_y)
+# project vector onto another
+#----------------------------------------------------------------------
+
+# to transform CM velocity components u/v to along/across mean l/c:
+# - mean dir d = &vel_dir(<u>,<v>); with <.> indicating ensemble avg
+# - l = proj(u,v,sin(rad(d)),cos(rad(d))); NEW: l = p_vel(d[,u,v])
+# - c = -proj(u,v,-cos(rad(d)),sin(rad(d)));
+
+sub proj(@)
+{
+ my($fx,$fy,$oux,$ouy) =
+ &antsFunUsage(4,"ffff","<from_x> <from_y> " .
+ "<onto_unit_x> <onto_unit_y>",@_);
+ return $fx*$oux + $fy*$ouy;
+}
+
+{ my(@fc);
+ sub p_vel(@)
+ {
+ my($u,$v,$d) = &antsFunUsage(3,'..f','[u, v,] dir',\@fc,'u','v',undef,@_);
+ return nan unless numbersp($d,$u,$v);
+ return proj($u,$v,sin(rad($d)),cos(rad($d)));
+ }
+}
+
+
+#----------------------------------------------------------------------
+# &polar_r(x,y),&vel_vel(u,v) calc polar radius, velocity
+# &polar_phi(x,y),&vel_dir(u,v) calc polar degrees cclockwise from
+# horiz (phi) OR clockwise from N (dir)
+# &cartesian_x(r,phi),&vel_u(m,dir) calc x and u from polar coords
+# &cartesian_y(r,phi),&vel_v(m,dir) calc y and v from polar coords
+#----------------------------------------------------------------------
+
+sub polar_r(@)
+{
+ my($x,$y) = &antsFunUsage(2,"ff","<x> <y>",@_);
+ return sqrt($x*$x+$y*$y);
+}
+
+{ my(@fc);
+ sub vel_speed(@)
+ {
+ my($u,$v) = &antsFunUsage(2,'..','[u, v]',\@fc,'u','v',@_); # . allows for nans
+ return nan unless numbersp($u,$v);
+ return sqrt($u*$u+$v*$v);
+ }
+}
+
+sub polar_phi(@)
+{
+ my($x,$y) = &antsFunUsage(2,"ff","<x> <y>",@_);
+ return 180 / $PI * atan2($y,$x);
+}
+
+
+{ my(@fc);
+ sub vel_dir(@)
+ {
+ my($u,$v) = &antsFunUsage(2,'..','[u, v]',\@fc,'u','v',@_); # . allows for nans
+ return nan unless numbersp($u,$v);
+ my($dir) = 180 / $PI * atan2($u,$v);
+ return ($dir >= 0) ? $dir : $dir+360;
+ }
+}
+
+sub cartesian_x(@)
+{
+ my($r,$phi) = &antsFunUsage(2,"ff","<r> <phi>",@_);
+ return $r * cos($PI*$phi/180);
+}
+
+sub vel_u(@) { return &cartesian_x($_[0],90-$_[1]); }
+
+sub cartesian_y(@)
+{
+ my($r,$phi) = &antsFunUsage(2,"ff","<r> <phi>",@_);
+ return $r * sin($PI*$phi/180);
+}
+
+sub vel_v(@) { return &cartesian_y($_[0],90-$_[1]); }
+
+#----------------------------------------------------------------------
+# &angle(val)
+# return angle in range [-180,180]
+# &angle_diff(ref_dir,dir)
+# return rotation between two angles
+# &rotation_ts(dir)
+# return time series of rotation
+# &angle_ts(dir)
+# return time series of angle without "wrap-around jumps"
+#----------------------------------------------------------------------
+
+sub angle(@)
+{
+ my($val) = &antsFunUsage(1,"f","<val>",@_);
+ $val += 360 while ($val < -180);
+ $val -= 360 while ($val > 180);
+ return $val;
+}
+
+sub angle_diff(@)
+{
+ my($m,$s) = &antsFunUsage(2,"ff","<minuend> <subtrahend>",@_);
+ return angle($m-$s);
+}
+
+{ my($last_in);
+
+ sub rotation_ts(@)
+ {
+ my($a) = &antsFunUsage(1,"f","<angle>",@_);
+
+ my($rot) = defined($last_in) ? angle_diff($a,$last_in) : nan;
+ $last_in = $a;
+ return $rot;
+ }
+}
+
+{ my($last_in,$last_out);
+
+ sub angle_ts(@)
+ {
+ my($a) = &antsFunUsage(1,"f","<angle>",@_);
+
+ $last_out = $last_in = $a
+ unless (defined($last_in));
+
+ $last_out += angle_diff($a,$last_in);
+ $last_in = $a;
+ return $last_out;
+ }
+}
+
+#----------------------------------------------------------------------
+# &ddeg(deg),&GMTdeg(deg) convert degree formats
+#----------------------------------------------------------------------
+
+sub ddeg(@)
+{
+ my($deg) = &antsFunUsage(1,"","<degrees in GMT format>",@_);
+ my($d,$m,$s) = split(':',$deg);
+ return ($d>=0) ? $d+$m/60+$s/3600
+ : $d-$m/60-$s/3600;
+}
+
+# NB: without roundoff code, results are as follows:
+# abc -Lvec 'GMTdeg(ddeg("10:11"))' -> 10:11:8.52651e-13
+# abc -Lvec 'GMTdeg(ddeg("10:10"))' -> 10:9:60
+sub GMTdeg(@)
+{
+ my($deg) = &antsFunUsage(1,"f","<degrees>",@_);
+ my($sgn); if ($deg < 0) { $sgn = '-'; $deg *= -1; }
+ my($min) = 60*($deg-int($deg));
+ my($sec) = 60*($min-int($min));
+ $sec=0,$min++ if equal($sec,60);
+ $sec=0 if equal($sec,0);
+ return sprintf("$sgn%d:%d:%g",int($deg),int($min),$sec);
+}
+
+sub degmin(@)
+{
+ my($deg) = &antsFunUsage(1,"f","<degrees>",@_);
+ my($sgn); if ($deg < 0) { $sgn = '-'; $deg *= -1; }
+ my($min) = 60*($deg-int($deg));
+ $min=0 if equal($min,0);
+ return sprintf("$sgn%d:%04.1f",int($deg),$min);
+}
+
+#----------------------------------------------------------------------
+# &dist(lat1,lon1,lat2,lon2) distance on globe (in m)
+# &dist12(...) ditto but with deg/min/sec separate
+# &dir(lat1,lon1,lat2,lon2) direction btw two points
+# &area(gmt_region) approximate area
+#----------------------------------------------------------------------
+
+sub dist(@)
+{
+ my($lat1,$lon1,$lat2,$lon2) =
+ &antsFunUsage(4,"","lat1 lon1 lat2 lon2",@_);
+
+ $lat1 = &ddeg($lat1);
+ $lat2 = &ddeg($lat2);
+ $lon1 = &ddeg($lon1);
+ $lon2 = &ddeg($lon2);
+
+ return 0 if ($lat1 == $lat2 && $lon1 == $lon2); # avoid roundoff
+
+ $radius = 6378139; # const
+ $pi = 3.14159265358979;
+ $d2r = $pi/180.0;
+
+ $ct1 = cos($d2r*$lat1);
+ $st1 = sin($d2r*$lat1);
+ $cp1 = cos($d2r*$lon1);
+ $sp1 = sin($d2r*$lon1);
+ $ct2 = cos($d2r*$lat2);
+ $st2 = sin($d2r*$lat2);
+ $cp2 = cos($d2r*$lon2);
+ $sp2 = sin($d2r*$lon2);
+
+ $cosine = $ct1*$cp1*$ct2*$cp2 + $ct1*$sp1*$ct2*$sp2 + $st1*$st2;
+ if ($cosine > 1.0) { $cosine = 1.0; }
+ if ($cosine < -1.0) { $cosine = -1.0; }
+
+ return $radius * acos($cosine);
+}
+
+sub dist12(@)
+{
+ my($la1d,$la1m,$la1s,$lo1d,$lo1m,$lo1s,
+ $la2d,$la2m,$la2s,$lo2d,$lo2m,$lo2s) =
+ &antsFunUsage(12,"ffffffffffff","lat1 m s lon1 m s lat2 m s lon2 m s",@_);
+ return dist(
+ ($la1d>=0)?$la1d+$la1m/60+$la1s/3600 : $la1d-$la1m/60-$la1s/3600,
+ ($lo1d>=0)?$lo1d+$lo1m/60+$lo1s/3600 : $lo1d-$lo1m/60-$lo1s/3600,
+ ($la2d>=0)?$la2d+$la2m/60+$la2s/3600 : $la2d-$la2m/60-$la2s/3600,
+ ($lo2d>=0)?$lo2d+$lo2m/60+$lo2s/3600 : $lo2d-$lo2m/60-$lo2s/3600
+ );
+}
+
+sub dir(@)
+{
+ my($lat1,$lon1,$lat2,$lon2) =
+ &antsFunUsage(4,"","lat1 lon1 lat2 lon2",@_);
+ my($dx) = dist(($lat1+$lat2)/2,$lon1,($lat1+$lat2)/2,$lon2);
+ $dx *= -1 if ($lon2 < $lon1);
+ my($dy) = dist($lat1,($lon1+$lon2)/2,$lat2,($lon1+$lon2)/2);
+ $dy *= -1 if ($lat2 < $lat1);
+ return ($dx == 0 && $dy == 0) ? nan : vel_dir($dx,$dy);
+}
+
+sub area(@)
+{
+ my($R) = &antsFunUsage(1,"",'<"W/E/S/N">',@_);
+ my($W,$E,$S,$N) = split('/',$R);
+
+ return (&dist($S,$W,$S,$E) + &dist($N,$W,$N,$E)) / 2 *
+ (&dist($S,$W,$N,$W) + &dist($S,$E,$N,$E)) / 2;
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/mrqcof.pl
@@ -0,0 +1,63 @@
+#======================================================================
+# M R Q C O F . P L
+# doc: Wed Feb 24 15:14:39 1999
+# dlm: Thu Feb 27 09:40:41 2003
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 30 0 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# MRQCOF routine from Numerical Recipes adapted for ANTS
+
+# Notes:
+# - data which has $antsFlagged[] TRUE is ignored
+# - x,y,sig are field numbers for data in $ants_
+# - if sig is a negative number, -sig is used as constant input stddev
+# - @A, @listA, @alpha, @beta, $chisq, &funcs are passed as references
+
+# HISTORY:
+# - Feb 24, 1999: - ported from c-source
+# - Jul 31, 1999: - BUG: first elt in $ants_ was ignored!
+
+require "$ANTS/nrutil.pl";
+
+sub mrqcof($$$$$$$$$)
+{
+ my($xfnr,$yfnr,$sig,$AR,$listAR,$alphaR,$betaR,$chiSqR,$funcsR) = @_;
+
+ my($k,$j,$i);
+ my($ymod,$wt,$sig2i,$dy,@dyda);
+
+ &vector(\@dyda,1,$#{$AR});
+ for ($j=1; $j<=$#{$listAR}; $j++) {
+ for ($k=1; $k<=$j; $k++) { $alphaR->[$j][$k] = 0.0; }
+ $betaR->[$j] = 0.0;
+ }
+ $$chiSqR = 0.0;
+ for ($i=0; $i<=$#ants_; $i++) {
+ next if ($antsFlagged[$i]);
+ $ymod = &$funcsR($ants_[$i][$xfnr],$AR,\@dyda);
+ if ($sig > 0) { # field number
+ $sig2i = 1.0/($ants_[$i][$sig]*$ants_[$i][$sig]);
+ } else { # const value
+ $sig2i = 1.0/($sig*$sig);
+ }
+ $dy = $ants_[$i][$yfnr] - $ymod;
+ for ($j=1; $j<=$#{$listAR}; $j++) {
+ $wt = $dyda[$listAR->[$j]]*$sig2i;
+ for ($k=1; $k<=$j; $k++) {
+ $alphaR->[$j][$k] += $wt*$dyda[$listAR->[$k]];
+# print(STDERR "alpha[$j][$k] = $alphaR->[$j][$k]\n");
+# print(STDERR "$wt,$dyda[$listAR->[$k]]\n");
+ }
+ $betaR->[$j] += $dy*$wt;
+ }
+ $$chiSqR += $dy*$dy*$sig2i;
+ }
+ for ($j=2; $j<=$#{$listAR}; $j++) {
+ for ($k=1; $k<=$j-1; $k++) {
+ $alphaR->[$k][$j] = $alphaR->[$j][$k];
+ }
+ }
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/mrqmin.pl
@@ -0,0 +1,106 @@
+#======================================================================
+# M R Q M I N . P L
+# doc: Wed Feb 24 15:10:22 1999
+# dlm: Tue Aug 22 22:05:43 2006
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 15 67 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# MRQMIN routine from Numerical Recipes adapted to ANTS
+# NB: based on 1st edtion of NR!!!!
+
+# HISTORY:
+# Mar 11, 1999: - created
+# Sep 27, 1999: - adapted to allow for new version of covsrt.pl as well
+# Aug 22, 2006: - changed require from covsrt_old.pl to covsrt.pl
+
+# Notes:
+# - x,y,sig are field numbers for data in $ants_
+# - if sig is a negative number, -sig is used as constant input stddev
+# - @A, @listA, @alpha, @covar, $chiSq, &funcs, $alamda passed as refs
+
+require "$ANTS/mrqcof.pl";
+require "$ANTS/gaussj.pl";
+require "$ANTS/covsrt.pl";
+require "$ANTS/nrutil.pl";
+
+{ # static scope
+ my(@da,@atry,@oneda,@beta,$oChiSq);
+
+ sub mrqmin($$$$$$$$$$)
+ {
+ my($xfnr,$yfnr,$sig,$AR,$listAR,$covarR,
+ $alphaR,$chiSqR,$funcsR,$alamdaR) = @_;
+
+ my($k,$kk,$j,$ihit);
+
+ if ($$alamdaR < 0.0) {
+ &matrix(\@oneda,1,$#{$AR},1,1);
+ &vector(\@atry,1,$#{$AR});
+ &vector(\@da,1,$#{$AR});
+ &vector(\@beta,1,$#{$AR});
+ $kk = $#{$listAR}+1;
+ for ($j=1; $j<=$#{$AR}; $j++) {
+ $ihit = 0;
+ for ($k=1; $k<=$#{$listAR}; $k++) {
+ if ($listAR->[$k] == $j) { $ihit++; }
+ }
+ if ($ihit == 0) {
+ $listAR->[$kk++] = $j;
+ } elsif ($ihit > 1) {
+ croak("Bad listA permutation in MRQMIN-1");
+ }
+ }
+ if ($kk != $#{$AR}+1) {
+ for ($ei=1; $ei<=$#{$listAR}; $ei++) {
+ print(STDERR "listA[$ei] = $listAR->[$ei]\n");
+ }
+ croak("Bad listA permutation in MRQMIN-2 " .
+ "($kk != $#{$AR}+1)");
+ }
+ $$alamdaR = 0.001;
+ &mrqcof($xfnr,$yfnr,$sig,$AR,$listAR,$alphaR,
+ \@beta,$chiSqR,$funcsR);
+ $oChiSq = $$chiSqR;
+ }
+ for ($j=1; $j<=$#{$listAR}; $j++) {
+ for ($k=1; $k<=$#{$listAR}; $k++) {
+ $covarR->[$j][$k] = $alphaR->[$j][$k];
+# print(STDERR "covar[$j][$k] = $covarR->[$j][$k]\n");
+ }
+ $covarR->[$j][$j] = $alphaR->[$j][$j]*(1.0+$$alamdaR);
+ $oneda[$j][1] = $beta[$j];
+ }
+ &gaussj($covarR,\@oneda);
+ for ($j=1; $j<=$#{$listAR}; $j++) {
+ $da[$j] = $oneda[$j][1];
+ }
+ if ($$alamdaR == 0.0) {
+ &covsrt($covarR,$listAR);
+ return;
+ }
+ for ($j=1; $j<=$#{$AR}; $j++) { $atry[$j] = $AR->[$j]; }
+ for ($j=1; $j<=$#{$listAR}; $j++) {
+ $atry[$listAR->[$j]] = $AR->[$listAR->[$j]]+$da[$j];
+ }
+ &mrqcof($xfnr,$yfnr,$sig,\@atry,$listAR,$covarR,\@da,$chiSqR,$funcsR);
+ if ($$chiSqR < $oChiSq) {
+ $$alamdaR *= 0.1;
+ $oChiSq = $$chiSqR;
+ for ($j=1; $j<=$#{$listAR}; $j++) {
+ for ($k=1; $k<=$#{$listAR}; $k++) {
+ $alphaR->[$j][$k] = $covarR->[$j][$k];
+ }
+ $beta[$j] = $da[$j];
+ $AR->[$listAR->[$j]] = $atry[$listAR->[$j]];
+ }
+ } else {
+ $$alamdaR *= 10.0;
+ $$chiSqR = $oChiSq;
+ }
+ return;
+ }
+
+} # end of static scope
+
+1;
new file mode 100644
--- /dev/null
+++ b/nrutil.pl
@@ -0,0 +1,77 @@
+#======================================================================
+# N R U T I L . P L
+# doc: Wed Feb 24 17:44:49 1999
+# dlm: Sun Jul 2 00:47:04 2006
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 45 31 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# extract from nrutil.c/nrutil.h (Numerical Recipes) adapted for ANTS
+
+# HISTORY:
+# Feb 24, 1999: - created from c-source
+# Aug 01, 1999: - added macros from nrutil.h
+# Sep 26, 1999: - added &dumpMatrix()
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+
+# NOTES:
+# - allocation routines &vector, &matrix needed to make sure
+# right number of elts is allocated (for $# op)
+# - array elts are initialized with nan
+# - array indices MUST start with 1 (in the spirit of FORTRAN IV, bless)
+# - instead of pointer return, we use refs
+
+sub vector($$$)
+{
+ my($vR,$nl,$nh) = @_;
+ my($i);
+
+ croak("vector must be 1-relative")
+ unless ($nl == 1);
+ for ($i=1; $i<=$nh; $i++) {
+ $vR->[$i] = nan;
+ }
+}
+
+sub matrix($$$$$)
+{
+ my($mR,$nrl,$nrh,$ncl,$nch) = @_;
+ my($i,$j);
+
+ croak("matrix must be 1-relative")
+ unless ($nrl == 1 && $ncl == 1);
+ for ($i=1; $i<=$nrh; $i++) {
+ for ($j=1; $j<=$nch; $j++) {
+ $mR->[$i][$j] = nan;
+ }
+ }
+}
+
+#----------------------------------------------------------------------
+
+sub dumpMatrix($$)
+{
+ my($msg,$mR) = @_;
+ my($rows) = $#{$mR};
+ my($cols) = $#{$mR->[1]};
+ my($r,$c);
+
+ print(STDERR "$msg: $rows x $cols (rows x cols)\n");
+ for ($r=1; $r<=$rows; $r++) {
+ for ($c=1; $c<=$cols; $c++) {
+ printf(STDERR "%.3e\t",$mR->[$r][$c]);
+ }
+ print(STDERR "\n");
+ }
+}
+
+#----------------------------------------------------------------------
+# Macros
+#----------------------------------------------------------------------
+
+sub SQR($) { return $_[0] * $_[0]; } # D?SQR
+sub MAX($$) { return ($_[0] > $_[1]) ? $_[0] : $_[1]; } # [DF]MAX
+sub MIN($$) { return ($_[0] < $_[1]) ? $_[0] : $_[1]; } # [DF]MIN
+sub SIGN($$) { return ($_[1] >= 0) ? $_[0] : -$_[0]; } # SIGN
+
+1;
new file mode 100644
--- /dev/null
+++ b/pearsn.pl
@@ -0,0 +1,69 @@
+#======================================================================
+# P E A R S N . P L
+# doc: Wed Mar 24 11:23:29 1999
+# dlm: Mon Jul 24 15:02:14 2006
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 26 0 NIL 0 0 72 66 2 4 NIL ofnI
+#======================================================================
+
+# HISTORY:
+# Mar 24, 1999: - created from NR c-version
+# Mar 26, 1999: - cosmetic changes
+# May 23, 1999: - allowed for N==2
+# Oct 04, 1999: - changed from specfuns to funs
+# Oct 13, 1999: - BUG: had to change TINY from 1e-20 to 1e-19
+# Nov 11, 1999: - BUG: had to change TINY from to 1e-16
+# Dec 11, 2001: - BUG: NaNs had not been handled correctly
+# Dec 12, 2001: - BUG: croak() had been used (this produces
+# a pipe #ERROR# output which is wrong
+# if pearsn is called within eval as in [fit])
+# Jan 9, 2006: - removed @antsFlagged
+
+require "$ANTS/libfuns.pl";
+
+{ # static scope
+
+my($TINY) = 1e-16; # for complete correlation
+
+# get correlation coefficient (retval); N (ref); significance level at which
+# null hypothesis of zero correlation is disproved (ref; small value
+# indicates significant correlation); and Fisher's z (ref). Missing refs
+# indicate values are not returned. Adapted for ANTS.
+
+sub pearsn(@)
+{
+ my($xfnr,$yfnr,$NR,$pR,$zR) = @_;
+ my($n,$r);
+ my($j);
+ my($yt,$xt,$t,$df);
+ my($syy,$sxy,$sxx,$ay,$ax);
+
+ for ($j=0; $j<=$#ants_; $j++) {
+ next unless (numberp($ants_[$j][$xfnr]) && numberp($ants_[$j][$yfnr]));
+ $n++;
+ $ax += $ants_[$j][$xfnr];
+ $ay += $ants_[$j][$yfnr];
+ }
+ die("$0 (pearsn.pl): no data\n") unless ($n >= 2);
+ $ax /= $n;
+ $ay /= $n;
+ for ($j=0; $j<=$#ants_; $j++) {
+ next unless (numberp($ants_[$j][$xfnr]) && numberp($ants_[$j][$yfnr]));
+ $xt = $ants_[$j][$xfnr] - $ax;
+ $yt = $ants_[$j][$yfnr] - $ay;
+ $sxx += $xt * $xt;
+ $syy += $yt * $yt;
+ $sxy += $xt * $yt;
+ }
+ $r = $sxy/(sqrt($sxx * $syy) + $TINY);
+ $df = $n - 2;
+ $t = $r * sqrt($df/((1-$r+$TINY) * (1+$r+$TINY)));
+ $$NR = $n if (defined($NR));
+ $$pR = ($n == 2) ? 0 : &betai(0.5*$df,0.5,$df/($df+$t*$t))
+ if (defined($pR));
+ $$zR = 0.5 * log((1+$r+$TINY) / (1-$r+$TINY))
+ if (defined($zR));
+ return $r;
+}
+
+} # end of static scope
new file mode 100644
--- /dev/null
+++ b/polint.pl
@@ -0,0 +1,76 @@
+#======================================================================
+# P O L I N T . P L
+# doc: Thu Nov 23 20:38:46 2000
+# dlm: Tue Aug 5 14:06:31 2008
+# (c) 2000 A.M. Thurnherr
+# uE-Info: 17 0 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# 2nd edition NR polint.c adapted to ANTS
+
+# HISTORY:
+# Nov 23, 2000: - created for [.interp.poly]
+# Jan 12, 2006: - BUG: higher-order polynomials could not be used
+# to interpolate linear function
+# Jul 1, 2006: - Version 3.3 [HISTORY]
+# Jul 28, 2006: - cosmetics
+# Aug 5, 2008: - BUG: [.interp.poly] takes data from ref, not @ants_
+
+# NOTES:
+# - &vector()-allocated arrays are numbered from 1
+# - (nan,nan) is returned on non-numeric required @ants_ values
+# - in contrast to the NR routine, the error value returned is +ve
+
+require "$ANTS/nrutil.pl";
+
+sub polint($$$$$$) # ($y,$dy) = &polint(...)
+{
+ my($dR,$xf,$xv,$ti,$n,$yf) = @_;
+ my($y,$dy);
+
+ my($i,$m); my($ns) = 1;
+ my($den,$dif,$dift,$ho,$hp,$w);
+ my(@c,@d);
+
+ for ($i=0; $i<$n; $i++) { # check for nans
+ return (nan,nan)
+ unless (numberp($dR->[$ti+$i][$xf]) &&
+ numberp($dR->[$ti+$i][$yf]));
+ }
+
+ $dif = abs($xv - $dR->[$ti][$xf]);
+ &vector(\@c,1,$n);
+ &vector(\@d,1,$n);
+ for ($i=1; $i<=$n; $i++) {
+ $dift = abs($xv - $dR->[$ti+$i-1][$xf]);
+ if ($dift < $dif) {
+ $ns = $i;
+ $dif = $dift;
+ }
+ $c[$i] = $dR->[$ti+$i-1][$yf];
+ $d[$i] = $dR->[$ti+$i-1][$yf];
+ }
+ $y = $dR->[$ti+$ns---1][$yf]; # WHAT A CONSTRUCT :-)
+ for ($m=1; $m<$n; $m++) {
+ for ($i=1; $i<=$n-$m; $i++) {
+ $ho = $dR->[$ti+$i-1][$xf] - $xv;
+ $hp = $dR->[$ti+$i+$m-1][$xf] - $xv;
+ $w = $c[$i+1] - $d[$i];
+ $den = $ho - $hp;
+### The following two lines of code are the original, which makes polint
+### fail when interpolating a linear function with a higher-order polynomial,
+### as is done in [ubtest/resample.TF].
+### croak("$0 (polint.pl): ERROR!") if ($den == 0);
+### $den = $w / $den;
+### The following line of code is the replacement that solves the bug.
+ $den = $w / $den unless ($den == 0);
+ $d[$i] = $hp * $den;
+ $c[$i] = $ho * $den;
+ }
+ $dy = (2*$ns < ($n-$m)) ? $c[$ns+1] : $d[$ns--];
+ $y += $dy;
+ }
+ return ($y,abs($dy));
+}
+
+1;
new file mode 100644
--- /dev/null
+++ b/pythag.pl
@@ -0,0 +1,25 @@
+#======================================================================
+# . / P Y T H A G . P L
+# doc: Sun Aug 1 10:41:34 1999
+# dlm: Sun Aug 1 10:46:43 1999
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 23 65 NIL 0 0 72 0 2 4 ofnI
+#======================================================================
+
+# PYTHAG routine from Numerical Recipes adapted to ANTS
+
+# HISTORY:
+# Aug 01, 1999: - manually converted from c-source
+
+sub pythag($$)
+{
+ my($a,$b) = @_; # params
+ my($absa,$absb); # float
+
+ $absa = abs($a);
+ $absb = abs($b);
+ return $absa*sqrt(1.0+SQR($absb/$absa))
+ if ($absa > $absb);
+ return ($absb == 0 ? 0 : $absb*sqrt(1+$absa*$absa/$absb/$absb)));
+}
+
new file mode 100644
--- /dev/null
+++ b/svbksb.pl
@@ -0,0 +1,46 @@
+#======================================================================
+# . / S V B K S B . P L
+# doc: Sat Jul 31 22:47:03 1999
+# dlm: Sat Jul 31 23:06:40 1999
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 30 32 NIL 0 0 72 2 2 4 ofnI
+#======================================================================
+
+# SVBKSB routine from Numerical Recipes adapted to ANTS
+
+# HISTORY:
+# Jul 31, 1999: - manually converted from c-source
+
+# Notes:
+# - everything passed as refs
+
+require "$ANTS/nrutil.pl";
+
+sub svbksb($$$$$)
+{
+ my($uR,$wR,$vR,$bR,$xR) = @_;
+ my($jj,$j,$i); # int
+ my($s); # float
+ my(@tmp); # float[]
+
+ &vector(\@tmp,1,$#{$wR});
+ for ($j=1; $j<=$#{$wR}; $j++) {
+ $s = 0;
+ if ($wR->[$j]) {
+ for ($i=1; $i<=$#{$uR}; $i++) {
+ $s += $uR->[$i][$j] * $bR->[$i];
+ }
+ $s /= $wR->[$j];
+ }
+ $tmp[$j]=$s;
+ }
+ for ($j=1; $j<=$#{$wR}; $j++) {
+ $s = 0;
+ for ($jj=1; $jj<=$#{$wR}; $jj++) {
+ $s += $vR->[$j][$jj] * tmp[$jj];
+ }
+ $x->[$j] = $s;
+ }
+}
+
+
new file mode 100644
--- /dev/null
+++ b/svdcmp.pl
@@ -0,0 +1,237 @@
+#======================================================================
+# S V D C M P . P L
+# doc: Sun Aug 1 09:51:37 1999
+# dlm: Thu Jul 19 09:45:52 2001
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 184 18 NIL 0 0 72 2 2 4 NIL ofnI
+#======================================================================
+
+# SVDCMP routine from Numerical Recipes adapted to ANTS
+
+# HISTORY:
+# Aug 01, 1999: - manually converted from c-source
+
+# Notes:
+# - everything passed as refs
+
+require "$ANTS/nrutil.pl";
+require "$ANTS/pythag.pl";
+
+sub svdcmp($$$)
+{
+ my($aR,$wR,$vR) = @_; # params
+ my($flag,$i,$its,$j,$jj,$k,$l,$nm); # int
+ my($anorm,$c,$f,$g,$h,$s,$scale,$x,$y,$z); # float
+ my(@rv1); # float[]
+
+ vector(\@rv1,1,$#{$vR});
+ for ($i=1; $i<=$#{$vR}; $i++) {
+ $l = $i+1;
+ $rv1[$i] = $scale*$g;
+ $g = 0; $s = 0; $scale = 0;
+ if ($i <= $#{$aR}) {
+ for ($k=$i; $k<=$#{$aR}; $k++) {
+ $scale += abs($aR->[$k][$i]);
+ }
+ if ($scale) {
+ for ($k=$i; $k<=$#{$aR}; $k++) {
+ $aR->[$k][$i] /= $scale;
+ $s += $aR->[$k][$i]*$aR->[$k][$i];
+ }
+ $f = $aR->[$i][$i];
+ $g = -&SIGN(sqrt($s),$f);
+ $h = $f*$g-$s;
+ $aR->[$i][$i] = $f-$g;
+ for ($j=$l; $j<=$#{$vR}; $j++) {
+ for ($s=0,$k=$i; $k<=$#{$aR}; $k++) {
+ $s += $aR->[$k][$i]*$aR->[$k][$j];
+ }
+ $f = $s/$h;
+ for ($k=$i; $k<=$#{$aR}; $k++) {
+ $aR->[$k][$j] += $f*$aR->[$k][$i];
+ }
+ }
+ for ($k=$i; $k<=$#{$aR}; $k++) {
+ $aR->[$k][$i] *= $scale;
+ }
+ }
+ }
+ $wR->[$i] = $scale * $g;
+ $g = 0; $s = 0; $scale = 0;
+ if ($i <= $#{$aR} && $i != $#{$vR}) {
+ for ($k=$l; $k<=$#{$vR}; $k++) {
+ $scale += abs($aR->[$i][$k]);
+ }
+ if ($scale) {
+ for ($k=$l; $k<=$#{$vR}; $k++) {
+ $aR->[$i][$k] /= $scale;
+ $s += $aR->[$i][$k]*$aR->[$i][$k];
+ }
+ $f = $aR->[$i][$l];
+ $g = -&SIGN(sqrt($s),$f);
+ $h = $f*$g-$s;
+ $aR->[$i][$l] = $f-$g;
+ for ($k=$l; $k<=$#{$vR}; $k++) {
+ $rv1[$k] = $aR->[$i][$k]/$h;
+ }
+ for ($j=$l; $j<=$#{$aR}; $j++) {
+ for ($s=0,$k=$l; $k<=$#{$vR}; $k++) {
+ $s += $aR->[$j][$k]*$aR->[$i][$k];
+ }
+ for ($k=$l; $k<=$#{$vR}; $k++) {
+ $aR->[$j][$k] += $s*$rv1[$k];
+ }
+ }
+ for ($k=$l; $k<=$#{$vR}; $k++) {
+ $aR->[$i][$k] *= $scale;
+ }
+ }
+ }
+ $anorm = &FMAX($anorm,(abs($wR->[$i])+abs($rv1[$i])));
+ }
+ for ($i=$#{$vR}; $i>=1; $i--) {
+ if ($i < $#{$vR}) {
+ if ($g) {
+ for ($j=$l; $j<=$#{$vR}; $j++) {
+ $vR->[$j][$i] = ($aR->[$i][$j]/$aR->[$i][$l])/$g;
+ }
+ for ($j=$l; $j<=$#{$vR}; $j++) {
+ for ($s=0,$k=$l; $k<=$#{$vR}; $k++) {
+ $s += $aR->[$i][$k]*$vR->[$k][$j];
+ }
+ for ($k=$l; $k<=$#{$vR}; $k++) {
+ $vR->[$k][$j] += $s*$vR->[$k][$i];
+ }
+ }
+ }
+ for ($j=$l; $j<=$#{$vR; $j++) {
+ $vR->[$i][$j] = 0; $vR->[$j][$i] = 0;
+ }
+ }
+ $vR->[$i][$i] = 1;
+ $g = $rv1[$i];
+ $l = $i;
+ }
+ for ($i=IMIN($#{$aR},$#{$vR}); $i>=1; $i--) {
+ $l = $i+1;
+ $g = $wR->[$i];
+ for ($j=$l; $j<=$#{$vR}; $j++) {
+ $aR->[$i][$j] = 0;
+ }
+ if ($g) {
+ $g = 1/$g;
+ for ($j=$l; $j<=$#{$vR}; $j++) {
+ for ($s=0,$k=$l; $k<=$#{$aR}; $k++) {
+ $s += $aR->[$k][$i]*$aR->[$k][$j];
+ }
+ $f = ($s/$aR->[$i][$i])*$g;
+ for ($k=$i; $k<=$#{$aR}; $k++) {
+ $aR->[$k][$j] += $f*$aR->[$k][$i];
+ }
+ }
+ for ($j=$i; $j<=$#{$aR}; $j++) {
+ $aR->[$j][$i] *= $g;
+ }
+ } else {
+ for ($j=$i; $j<=$#{$aR}; $j++) {
+ $aR->[$j][$i] = 0;
+ }
+ }
+ ++$aR->[$i][$i];
+ }
+ for ($k=$#{$vR}; $k>=1; $k--) {
+ for ($its=1; $its<=30; $its++) {
+ $flag = 1;
+ for ($l=$k; $l>=1; $l--) {
+ $nm = $l-1;
+ if ((abs($rv1[$l])+$anorm) == $anorm) {
+ $flag = 0;
+ break;
+ }
+ break if ((abs($wR->[$nm])+$anorm) == $anorm);
+ }
+ if ($flag) {
+ $c = 0;
+ $s = 1;
+ for ($i=$l; $i<=$k; $i++) {
+ $f = $s*$rv1[$i];
+ $rv1[$i] = $c*$rv1[$i];
+ break if ((abs($f)+$anorm) == $anorm);
+ $g = $wR->[$i];
+ $h = &pythag($f,$g);
+ $wR->[$i] = $h;
+ $h = 1/$h;
+ $c = $g*$h;
+ $s = -$f*$h;
+ for ($j=1; $j<=$#{$aR}; $j++) {
+ $y = $aR->[$j][$nm];
+ $z = $aR->[$j][$i];
+ $aR->[$j][$nm] = $y*$c+$z*$s;
+ $aR->[$j][$i] = $z*$c-$y*$s;
+ }
+ }
+ }
+ $z = $wR->[$k];
+ if ($l == $k) {
+ if ($z < 0) {
+ $wR->[$k] = -$z;
+ for ($j=1; $j<=$#{$vR}; $j++) {
+ $vR->[$j][$k] = -$vR->[$j][$k];
+ }
+ }
+ break;
+ }
+ croak("no convergence in 30 svdcmp iterations\n") if ($its == 30);
+ $x = $wR->[$l];
+ $nm = $k-1;
+ $y = $wR->[$nm];
+ $g = $rv1[$nm];
+ $h = $rv1[$k];
+ $f = (($y-$z)*($y+$z)+($g-$h)*($g+$h))/(2.0*$h*$y);
+ $g = &pythag($f,1);
+ $f = (($x-$z)*($x+$z)+$h*(($y/($f+&SIGN($g,$f)))-$h))/$x;
+ $c = 1; $s = 1;
+ for ($j=$l; $j<=$nm; $j++) {
+ $i = $j+1;
+ $g = $rv1[$i];
+ $y = $wR->[$i];
+ $h = $s*$g;
+ $g = $c*$g;
+ $z = &pythag($f,$h);
+ $rv1[$j] = $z;
+ $c = $f/$z;
+ $s = $h/$z;
+ $f = $x*$c+$g*$s;
+ $g = $g*$c-$x*$s;
+ $h = $y*$s;
+ $y *= $c;
+ for ($jj=1; $jj<=$#{$vR}; $jj++) {
+ $x = $vR->[$jj][$j];
+ $z = $vR->[$jj][$i];
+ $vR->[$jj][$j] = $x*$c+$z*$s;
+ $vR->[$jj][$i] = $z*$c-$x*$s;
+ }
+ $z = &pythag($f,$h);
+ $wR->[$j] = $z;
+ if ($z) {
+ $z = 1/$z;
+ $c = $f*$z;
+ $s = $h*$z;
+ }
+ $f = $c*$g+$s*$y;
+ $x = $c*$y-$s*$g;
+ for ($jj=1; $jj<=$#{$aR}; $jj++) {
+ $y = $aR->[$jj][$j];
+ $z = $aR->[$jj][$i];
+ $aR->[$jj][$j] = $y*$c+$z*$s;
+ $aR->[$jj][$i] = $z*$c-$y*$s;
+ }
+ }
+ $rv1[$l] = 0;
+ $rv1[$k] = $f;
+ $wR->[$k] = $x;
+ }
+ }
+}
+
+
new file mode 100644
--- /dev/null
+++ b/svdfit.pl
@@ -0,0 +1,68 @@
+#======================================================================
+# . / S V D F I T . P L
+# doc: Sat Jul 31 22:09:25 1999
+# dlm: Sat Jul 31 22:45:40 1999
+# (c) 1999 A.M. Thurnherr
+# uE-Info: 61 36 NIL 0 0 72 2 2 4 ofnI
+#======================================================================
+
+# SVDFIT routine from Numerical Recipes adapted to ANTS
+
+# HISTORY:
+# Jul 31, 1999: - manually converted from c-source
+
+# Notes:
+# - x,y,sig are field numbers for data in $ants_
+# - if sig is a negative number, -sig is used as constant input stddev
+# - @a, @u, @v, @w, &funcs passed as refs
+# - chi square is returned
+
+require "$ANTS/nrutil.pl";
+require "$ANTS/svbksb.pl";
+require "$ANTS/svdcmp.pl";
+
+{ # BEGIN static scope
+
+my($TOL) = 1.0e-5;
+
+sub svdfit($$$$$$$$)
+{
+ my($xfnr,$yfnr,$sig,$aR,$uR,$vR,$wR,$funcsR) = @_;
+ my($j,$i); # int
+ my($chisq,$wmax,$tmp,$thresh,$sum); # float
+ my(@b,@afunc); # float[]
+
+ &vector(\@b,1,$#ants_);
+ &vector(\@afunc,1,$#{$aR});
+ for ($i=0; $i<=$#ants_; $i++) {
+ next if ($antsFlagged[$i]);
+ &$funcsR($ants_[$i][$xfnr],\@afunc);
+ $tmp = 1.0 / (($sig > 0) ? $ants_[$i][$sig] : -$sig);
+ for ($j=1; $j<=$#{$aR}; $j++) {
+ $uR->[$i][$j] = $afunc[$j]*$tmp;
+ }
+ $b[$i] = $ants_[$i][$yfnr]*$tmp;
+ }
+ &svdcmp($uR,$wR,$vR);
+ for ($j=1; $j<=$#{$aR}; $j++) {
+ $wmax = $wR->[$j] if ($wR->[$j] > $wmax);
+ }
+ $thresh = $TOL*$wmax;
+ for ($j=1; $j<=$#{$aR}; $j++) {
+ $wR->[$j] = 0 if ($wR->[$j] < $thresh);
+ }
+ &svbksb($uR,$wR,$vR,\@b,$aR);
+ for ($i=0; $i<=$#ants_; $i++) {
+ next if ($antsFlagged[$i]);
+ &$funcsR($ants_[$i][$xfnr],\@afunc);
+ for ($j=1; $j<=$#{$aR}; $j++) {
+ $sum += $aR->[$j]*$afunc[$j];
+ }
+ $tmp = ($ants_[$i][$yfnr] - $sum) /
+ (($sig > 0) ? $ants_[$i][$sig] : -$sig);
+ $chisq += $tmp * $tmp;
+ }
+ return $chisq;
+}
+
+} # END static scope